This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
7da20be95f5a400d9223dfe578dba714b34d7ea0
[perl5.git] / cpan / Filter-Util-Call / t / call.t
1 use Config;
2 BEGIN {
3     if ($ENV{PERL_CORE}) {
4         if ($Config{'extensions'} !~ m{\bFilter/Util/Call\b}) {
5             print "1..0 # Skip: Filter::Util::Call was not built\n";
6             exit 0;
7         }
8     }
9     unshift @INC, 't';
10     require 'filter-util.pl';
11 }
12
13 use strict;
14 use warnings;
15
16 use vars qw($Inc $Perl);
17
18 print "1..32\n" ;
19
20 $Perl = "$Perl -w" ;
21
22 use Cwd ;
23 my $here = getcwd ;
24
25
26 my $filename = "call$$.tst" ;
27 my $filename2 = "call2$$.tst" ;
28 my $filenamebin = "call$$.bin" ;
29 my $module   = "MyTest" ;
30 my $module2  = "MyTest2" ;
31 my $module3  = "MyTest3" ;
32 my $module4  = "MyTest4" ;
33 my $module5  = "MyTest5" ;
34 my $module6  = "MyTest6" ;
35 my $nested   = "nested" ;
36 my $block   = "block" ;
37 my $redir   = $^O eq 'MacOS' ? "" : "2>&1";
38
39 # Test error cases
40 ##################
41
42 # no filter function in module 
43 ###############################
44
45 writeFile("${module}.pm", <<EOM) ;
46 package ${module} ;
47
48 use Filter::Util::Call ;
49  
50 sub import { filter_add(bless []) }
51
52 1 ;
53 EOM
54  
55 my $a = `$Perl "-I." $Inc -e "use ${module} ;"  $redir` ;
56 ok(1, (($? >>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'MacOS' || $^O eq 'NetWare' || $^O eq 'mpeix') && $? != 0))) ;
57 ok(2, $a =~ /^Can't locate object method "filter" via package "MyTest"/m) ;
58  
59 # no reference parameter in filter_add
60 ######################################
61
62 writeFile("${module}.pm", <<EOM) ;
63 package ${module} ;
64  
65 use Filter::Util::Call ;
66  
67 sub import { filter_add() }
68  
69 1 ;
70 EOM
71
72 $a = `$Perl "-I." $Inc -e "use ${module} ;"  $redir` ;
73 #warn "# $a\n";
74 ok(3, (($? >>8) != 0 
75        or (($^O eq 'MSWin32' || $^O eq 'MacOS' || $^O eq 'NetWare' || $^O eq 'mpeix')
76            && $? != 0))) ;
77 #ok(4, $a =~ /^usage: filter_add\(ref\) at ${module}.pm/) ;
78 my $errmsg = $Config{usecperl}
79   ? qr/^Not enough arguments for subroutine entry Filter::Util::Call::filter_add at ${module}\.pm line/m
80   : qr/^Not enough arguments for Filter::Util::Call::filter_add at ${module}\.pm line/m;
81 $a =~ s/^(.*?\n).*$/$1/s; # only the first line
82 if ($] < 5.007) {
83     if ($a =~ $errmsg) {
84         ok(4, 1);
85     } else {
86         ok(4, 1, "TODO");
87     }
88 } else {
89     ok(4, $a =~ $errmsg, 'usage error')
90        or diag("The error was: ", $a);
91 }
92
93 # non-error cases
94 #################
95
96
97 # a simple filter, using a closure
98 #################
99
100 writeFile("${module}.pm", <<EOM, <<'EOM') ;
101 package ${module} ;
102  
103 EOM
104 use Filter::Util::Call ;
105 sub import { 
106     filter_add(
107         sub {
108
109             my ($status) ;
110
111             if (($status = filter_read()) > 0) {
112                 s/ABC/DEF/g 
113             }
114             $status ;
115         } ) ;
116 }
117
118 1 ;
119 EOM
120  
121 writeFile($filename, <<EOM, <<'EOM') ;
122
123 use $module ;
124 EOM
125
126 use Cwd ;
127 $here = getcwd ;
128 print "I am $here\n" ;
129 print "some letters ABC\n" ;
130 $y = "ABCDEF" ;
131 print <<EOF ;
132 Alphabetti Spagetti ($y)
133 EOF
134
135 EOM
136
137 $a = `$Perl "-I." $Inc $filename  $redir` ;
138 ok(5, ($? >>8) == 0) ;
139 ok(6, $a eq <<EOM) ;
140 I am $here
141 some letters DEF
142 Alphabetti Spagetti (DEFDEF)
143 EOM
144
145 # a simple filter, not using a closure
146 #################
147  
148 writeFile("${module}.pm", <<EOM, <<'EOM') ;
149 package ${module} ;
150  
151 EOM
152 use Filter::Util::Call ;
153 sub import { filter_add(bless []) }
154  
155 sub filter
156 {
157     my ($self) = @_ ;
158     my ($status) ;
159  
160     if (($status = filter_read()) > 0) {
161         s/ABC/DEF/g
162     }
163     $status ;
164 }
165
166  
167 1 ;
168 EOM
169  
170 writeFile($filename, <<EOM, <<'EOM') ;
171  
172 use $module ;
173 EOM
174  
175 use Cwd ;
176 $here = getcwd ;
177 print "I am $here\n" ;
178 print "some letters ABC\n" ;
179 $y = "ABCDEF" ;
180 print <<EOF ;
181 Alphabetti Spagetti ($y)
182 EOF
183  
184 EOM
185  
186 $a = `$Perl "-I." $Inc $filename  $redir` ;
187 ok(7, ($? >>8) == 0) ;
188 ok(8, $a eq <<EOM) ;
189 I am $here
190 some letters DEF
191 Alphabetti Spagetti (DEFDEF)
192 EOM
193
194
195 # nested filters
196 ################
197
198
199 writeFile("${module2}.pm", <<EOM, <<'EOM') ;
200 package ${module2} ;
201 use Filter::Util::Call ;
202  
203 EOM
204 sub import { filter_add(bless []) }
205  
206 sub filter
207 {
208     my ($self) = @_ ;
209     my ($status) ;
210  
211     if (($status = filter_read()) > 0) {
212         s/XYZ/PQR/g
213     }
214     $status ;
215 }
216  
217 1 ;
218 EOM
219  
220 writeFile("${module3}.pm", <<EOM, <<'EOM') ;
221 package ${module3} ;
222 use Filter::Util::Call ;
223  
224 EOM
225 sub import { filter_add(
226  
227     sub 
228     {
229         my ($status) ;
230
231         if (($status = filter_read()) > 0) {
232             s/Fred/Joe/g
233         }
234         $status ;
235     } ) ;
236 }
237
238 1 ;
239 EOM
240
241 writeFile("${module4}.pm", <<EOM) ;
242 package ${module4} ;
243
244 use $module5 ;
245
246 print "I'm feeling used!\n" ;
247 print "Fred Joe ABC DEF PQR XYZ\n" ;
248 print "See you Today\n" ;
249 1;
250 EOM
251
252 writeFile("${module5}.pm", <<EOM, <<'EOM') ;
253 package ${module5} ;
254 use Filter::Util::Call ;
255  
256 EOM
257 sub import { filter_add(bless []) }
258  
259 sub filter
260 {
261     my ($self) = @_ ;
262     my ($status) ;
263  
264     if (($status = filter_read()) > 0) {
265         s/Today/Tomorrow/g
266     }
267     $status ;
268 }
269  
270 1 ;
271 EOM
272
273 writeFile($filename, <<EOM, <<'EOM') ;
274  
275 # two filters for this file
276 use $module ;
277 use $module2 ;
278 require "$nested" ;
279 use $module4 ;
280 EOM
281  
282 print "some letters ABCXYZ\n" ;
283 $y = "ABCDEFXYZ" ;
284 print <<EOF ;
285 Fred likes Alphabetti Spagetti ($y)
286 EOF
287  
288 EOM
289  
290 writeFile($nested, <<EOM, <<'EOM') ;
291 use $module3 ;
292 EOM
293  
294 print "This is another file XYZ\n" ;
295 print <<EOF ;
296 Where is Fred?
297 EOF
298  
299 EOM
300
301 $a = `$Perl "-I." $Inc $filename  $redir` ;
302 ok(9, ($? >>8) == 0) ;
303 ok(10, $a eq <<EOM) ;
304 I'm feeling used!
305 Fred Joe ABC DEF PQR XYZ
306 See you Tomorrow
307 This is another file XYZ
308 Where is Joe?
309 some letters DEFPQR
310 Fred likes Alphabetti Spagetti (DEFDEFPQR)
311 EOM
312
313 # using the module context (with a closure)
314 ###########################################
315  
316  
317 writeFile("${module2}.pm", <<EOM, <<'EOM') ;
318 package ${module2} ;
319 use Filter::Util::Call ;
320  
321 EOM
322 sub import
323 {
324     my ($type) = shift ;
325     my (@strings) = @_ ;
326  
327  
328     filter_add (
329  
330         sub 
331         {
332             my ($status) ;
333             my ($pattern) ;
334              
335             if (($status = filter_read()) > 0) {
336                 foreach $pattern (@strings)
337                     { s/$pattern/PQR/g }
338             }
339              
340             $status ;
341         }
342         )
343  
344 }
345 1 ;
346 EOM
347  
348  
349 writeFile($filename, <<EOM, <<'EOM') ;
350  
351 use $module2 qw( XYZ KLM) ;
352 use $module2 qw( ABC NMO) ;
353 EOM
354  
355 print "some letters ABCXYZ KLM NMO\n" ;
356 $y = "ABCDEFXYZKLMNMO" ;
357 print <<EOF ;
358 Alphabetti Spagetti ($y)
359 EOF
360  
361 EOM
362  
363 $a = `$Perl "-I." $Inc $filename  $redir` ;
364 ok(11, ($? >>8) == 0) ;
365 ok(12, $a eq <<EOM) ;
366 some letters PQRPQR PQR PQR
367 Alphabetti Spagetti (PQRDEFPQRPQRPQR)
368 EOM
369  
370
371
372 # using the module context (without a closure)
373 ##############################################
374
375
376 writeFile("${module2}.pm", <<EOM, <<'EOM') ;
377 package ${module2} ;
378 use Filter::Util::Call ;
379  
380 EOM
381 sub import 
382
383     my ($type) = shift ;
384     my (@strings) = @_ ;
385
386   
387     filter_add (bless [@strings]) 
388 }
389  
390 sub filter
391 {
392     my ($self) = @_ ;
393     my ($status) ;
394     my ($pattern) ;
395  
396     if (($status = filter_read()) > 0) {
397         foreach $pattern (@$self)
398           { s/$pattern/PQR/g }
399     }
400
401     $status ;
402 }
403  
404 1 ;
405 EOM
406  
407  
408 writeFile($filename, <<EOM, <<'EOM') ;
409  
410 use $module2 qw( XYZ KLM) ;
411 use $module2 qw( ABC NMO) ;
412 EOM
413  
414 print "some letters ABCXYZ KLM NMO\n" ;
415 $y = "ABCDEFXYZKLMNMO" ;
416 print <<EOF ;
417 Alphabetti Spagetti ($y)
418 EOF
419  
420 EOM
421  
422 $a = `$Perl "-I." $Inc $filename  $redir` ;
423 ok(13, ($? >>8) == 0) ;
424 ok(14, $a eq <<EOM) ;
425 some letters PQRPQR PQR PQR
426 Alphabetti Spagetti (PQRDEFPQRPQRPQR)
427 EOM
428
429 # multi line test
430 #################
431
432
433 writeFile("${module2}.pm", <<EOM, <<'EOM') ;
434 package ${module2} ;
435 use Filter::Util::Call ;
436  
437 EOM
438 sub import
439
440     my ($type) = shift ;
441     my (@strings) = @_ ;
442
443   
444     filter_add(bless []) 
445 }
446  
447 sub filter
448 {
449     my ($self) = @_ ;
450     my ($status) ;
451  
452     # read first line
453     if (($status = filter_read()) > 0) {
454         chop ;
455         s/\r$//;
456         # and now the second line (it will append)
457         $status = filter_read() ;
458     }
459
460     $status ;
461 }
462  
463 1 ;
464 EOM
465  
466  
467 writeFile($filename, <<EOM, <<'EOM') ;
468  
469 use $module2  ;
470 EOM
471 print "don't cut me 
472 in half\n" ;
473 print  
474 <<EOF ;
475 appen
476 ded
477 EO
478 F
479  
480 EOM
481  
482 $a = `$Perl "-I." $Inc $filename  $redir` ;
483 ok(15, ($? >>8) == 0) ;
484 ok(16, $a eq <<EOM) ;
485 don't cut me in half
486 appended
487 EOM
488
489 # Block test
490 #############
491
492 writeFile("${block}.pm", <<EOM, <<'EOM') ;
493 package ${block} ;
494 use Filter::Util::Call ;
495  
496 EOM
497 sub import
498
499     my ($type) = shift ;
500     my (@strings) = @_ ;
501
502   
503     filter_add (bless [@strings] )
504 }
505  
506 sub filter
507 {
508     my ($self) = @_ ;
509     my ($status) ;
510     my ($pattern) ;
511  
512     filter_read(20)  ;
513 }
514  
515 1 ;
516 EOM
517
518 my $string = <<'EOM' ;
519 print "hello mum\n" ;
520 $x = 'me ' x 3 ;
521 print "Who wants it?\n$x\n" ;
522 EOM
523
524
525 writeFile($filename, <<EOM, $string ) ;
526 use $block ;
527 EOM
528  
529 $a = `$Perl "-I." $Inc $filename  $redir` ;
530 ok(17, ($? >>8) == 0) ;
531 ok(18, $a eq <<EOM) ;
532 hello mum
533 Who wants it?
534 me me me 
535 EOM
536
537 # use in the filter
538 ####################
539
540 writeFile("${block}.pm", <<EOM, <<'EOM') ;
541 package ${block} ;
542 use Filter::Util::Call ;
543  
544 EOM
545 use Cwd ;
546
547 sub import
548
549     my ($type) = shift ;
550     my (@strings) = @_ ;
551
552   
553     filter_add(bless [@strings] )
554 }
555  
556 sub filter
557 {
558     my ($self) = @_ ;
559     my ($status) ;
560     my ($here) = quotemeta getcwd ;
561  
562     if (($status = filter_read()) > 0) {
563         s/DIR/$here/g
564     }
565     $status ;
566 }
567  
568 1 ;
569 EOM
570
571 writeFile($filename, <<EOM, <<'EOM') ;
572 use $block ;
573 EOM
574 print "We are in DIR\n" ;
575 EOM
576  
577 $a = `$Perl "-I." $Inc $filename  $redir` ;
578 ok(19, ($? >>8) == 0) ;
579 ok(20, $a eq <<EOM) ;
580 We are in $here
581 EOM
582
583
584 # filter_del
585 #############
586  
587 writeFile("${block}.pm", <<EOM, <<'EOM') ;
588 package ${block} ;
589 use Filter::Util::Call ;
590  
591 EOM
592  
593 sub import
594 {
595     my ($type) = shift ;
596     my ($count) = @_ ;
597  
598  
599     filter_add(bless \$count )
600 }
601  
602 sub filter
603 {
604     my ($self) = @_ ;
605     my ($status) ;
606  
607     s/HERE/THERE/g
608         if ($status = filter_read()) > 0 ;
609
610     -- $$self ;
611     filter_del() if $$self <= 0 ;
612
613     $status ;
614 }
615  
616 1 ;
617 EOM
618  
619 writeFile($filename, <<EOM, <<'EOM') ;
620 use $block (3) ;
621 EOM
622 print "
623 HERE I am
624 I am HERE
625 HERE today gone tomorrow\n" ;
626 EOM
627  
628 $a = `$Perl "-I." $Inc $filename  $redir` ;
629 ok(21, ($? >>8) == 0) ;
630 ok(22, $a eq <<EOM) ;
631
632 THERE I am
633 I am THERE
634 HERE today gone tomorrow
635 EOM
636
637
638 # filter_read_exact
639 ####################
640  
641 writeFile("${block}.pm", <<EOM, <<'EOM') ;
642 package ${block} ;
643 use Filter::Util::Call ;
644  
645 EOM
646  
647 sub import
648 {
649     my ($type) = shift ;
650  
651     filter_add(bless [] )
652 }
653  
654 sub filter
655 {
656     my ($self) = @_ ;
657     my ($status) ;
658  
659     if (($status = filter_read_exact(9)) > 0) {
660         s/HERE/THERE/g
661     }
662  
663     $status ;
664 }
665  
666 1 ;
667 EOM
668  
669 writeFile($filenamebin, <<EOM, <<'EOM') ;
670 use $block ;
671 EOM
672 print "
673 HERE I am
674 I'm HERE
675 HERE today gone tomorrow\n" ;
676 EOM
677  
678 $a = `$Perl "-I." $Inc $filenamebin  $redir` ;
679 ok(23, ($? >>8) == 0) ;
680 ok(24, $a eq <<EOM) ;
681
682 HERE I am
683 I'm THERE
684 THERE today gone tomorrow
685 EOM
686
687 {
688
689 # Check __DATA__
690 ####################
691  
692 writeFile("${block}.pm", <<EOM, <<'EOM') ;
693 package ${block} ;
694 use Filter::Util::Call ;
695  
696 EOM
697  
698 sub import
699 {
700     my ($type) = shift ;
701  
702     filter_add([])
703 }
704  
705 sub filter
706 {
707     my ($self) = @_ ;
708     my ($status) ;
709  
710     if (($status = filter_read()) > 0) {
711         s/HERE/THERE/g
712     }
713  
714     $status ;
715 }
716  
717 1 ;
718 EOM
719  
720 writeFile($filename, <<EOM, <<'EOM') ;
721 use $block ;
722 EOM
723 print "HERE HERE\n";
724 @a = <DATA>;
725 print @a;
726 __DATA__
727 HERE I am
728 I'm HERE
729 HERE today gone tomorrow
730 EOM
731  
732 $a = `$Perl "-I." $Inc $filename  $redir` ;
733 ok(25, ($? >>8) == 0) ;
734 ok(26, $a eq <<EOM) ;
735 THERE THERE
736 HERE I am
737 I'm HERE
738 HERE today gone tomorrow
739 EOM
740
741 }
742
743 {
744
745 # Check __END__
746 ####################
747  
748 writeFile("${block}.pm", <<EOM, <<'EOM') ;
749 package ${block} ;
750 use Filter::Util::Call ;
751  
752 EOM
753  
754 sub import
755 {
756     my ($type) = shift ;
757  
758     filter_add(bless [] )
759 }
760  
761 sub filter
762 {
763     my ($self) = @_ ;
764     my ($status) ;
765  
766     if (($status = filter_read()) > 0) {
767         s/HERE/THERE/g
768     }
769  
770     $status ;
771 }
772  
773 1 ;
774 EOM
775  
776 writeFile($filename, <<EOM, <<'EOM') ;
777 use $block ;
778 EOM
779 print "HERE HERE\n";
780 @a = <DATA>;
781 print @a;
782 __END__
783 HERE I am
784 I'm HERE
785 HERE today gone tomorrow
786 EOM
787  
788 $a = `$Perl "-I." $Inc $filename  $redir` ;
789 ok(27, ($? >>8) == 0) ;
790 ok(28, $a eq <<EOM) ;
791 THERE THERE
792 HERE I am
793 I'm HERE
794 HERE today gone tomorrow
795 EOM
796
797 }
798
799 {
800
801 # no without use
802 # see Message-ID: <2002110621.427.A15377@ttul.org>
803 ####################
804
805 writeFile("${module6}.pm", <<EOM);
806 package ${module6} ;
807 #use Filter::Simple;
808 #FILTER {}
809 use Filter::Util::Call;
810 sub import { filter_add(sub{}) }
811 sub unimport { filter_del() }
812 1;
813 EOM
814
815 writeFile($filename2, <<EOM);
816 no ${module6} ;
817 print "ok";
818 EOM
819
820 my $str = $^O eq 'MacOS' ? "'ok'" : "q{ok}";
821 my $a = `$Perl "-I." $Inc -e "no ${module6}; print $str"`;
822 ok(29, ($? >>8) == 0);
823 chomp( $a ) if $^O eq 'VMS';
824 ok(30, $a eq 'ok');
825
826 $a = `$Perl "-I." $Inc $filename2`;
827 ok(31, ($? >>8) == 0);
828 chomp( $a ) if $^O eq 'VMS';
829 ok(32, $a eq 'ok');
830
831 }
832
833 END {
834     1 while unlink $filename ;
835     1 while unlink $filename2 ;
836     1 while unlink $filenamebin ;
837     1 while unlink "${module}.pm" ;
838     1 while unlink "${module2}.pm" ;
839     1 while unlink "${module3}.pm" ;
840     1 while unlink "${module4}.pm" ;
841     1 while unlink "${module5}.pm" ;
842     1 while unlink "${module6}.pm" ;
843     1 while unlink $nested ;
844     1 while unlink "${block}.pm" ;
845 }
846
847