This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Filter::Util::Call to CPAN version 1.58
[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..34\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 #print "# $a\n";
489
490 # Block test
491 #############
492
493 writeFile("${block}.pm", <<EOM, <<'EOM') ;
494 package ${block} ;
495 use Filter::Util::Call ;
496
497 EOM
498 sub import
499 {
500     my ($type) = shift ;
501     my (@strings) = @_ ;
502
503
504     filter_add (bless [@strings] )
505 }
506
507 sub filter
508 {
509     my ($self) = @_ ;
510     my ($status) ;
511     my ($pattern) ;
512
513     filter_read(20)  ;
514 }
515
516 1 ;
517 EOM
518
519 my $string = <<'EOM' ;
520 print "hello mum\n" ;
521 $x = 'me ' x 3 ;
522 print "Who wants it?\n$x\n" ;
523 EOM
524
525
526 writeFile($filename, <<EOM, $string ) ;
527 use $block ;
528 EOM
529
530 $a = `$Perl "-I." $Inc $filename  $redir` ;
531 ok(17, ($? >>8) == 0) ;
532 ok(18, $a eq <<EOM) ;
533 hello mum
534 Who wants it?
535 me me me 
536 EOM
537
538 # use in the filter
539 ####################
540
541 writeFile("${block}.pm", <<EOM, <<'EOM') ;
542 package ${block} ;
543 use Filter::Util::Call ;
544
545 EOM
546 use Cwd ;
547
548 sub import
549 {
550     my ($type) = shift ;
551     my (@strings) = @_ ;
552
553
554     filter_add(bless [@strings] )
555 }
556
557 sub filter
558 {
559     my ($self) = @_ ;
560     my ($status) ;
561     my ($here) = quotemeta getcwd ;
562
563     if (($status = filter_read()) > 0) {
564         s/DIR/$here/g
565     }
566     $status ;
567 }
568
569 1 ;
570 EOM
571
572 writeFile($filename, <<EOM, <<'EOM') ;
573 use $block ;
574 EOM
575 print "We are in DIR\n" ;
576 EOM
577
578 $a = `$Perl "-I." $Inc $filename  $redir` ;
579 ok(19, ($? >>8) == 0) ;
580 ok(20, $a eq <<EOM) ;
581 We are in $here
582 EOM
583
584
585 # filter_del
586 #############
587
588 writeFile("${block}.pm", <<EOM, <<'EOM') ;
589 package ${block} ;
590 use Filter::Util::Call ;
591
592 EOM
593
594 sub import
595 {
596     my ($type) = shift ;
597     my ($count) = @_ ;
598
599
600     filter_add(bless \$count )
601 }
602
603 sub filter
604 {
605     my ($self) = @_ ;
606     my ($status) ;
607
608     s/HERE/THERE/g
609         if ($status = filter_read()) > 0 ;
610
611     -- $$self ;
612     filter_del() if $$self <= 0 ;
613
614     $status ;
615 }
616
617 1 ;
618 EOM
619
620 writeFile($filename, <<EOM, <<'EOM') ;
621 use $block (3) ;
622 EOM
623 print "
624 HERE I am
625 I am HERE
626 HERE today gone tomorrow\n" ;
627 EOM
628
629 $a = `$Perl "-I." $Inc $filename  $redir` ;
630 ok(21, ($? >>8) == 0) ;
631 ok(22, $a eq <<EOM) ;
632
633 THERE I am
634 I am THERE
635 HERE today gone tomorrow
636 EOM
637
638
639 # filter_read_exact
640 ####################
641
642 writeFile("${block}.pm", <<EOM, <<'EOM') ;
643 package ${block} ;
644 use Filter::Util::Call ;
645
646 EOM
647
648 sub import
649 {
650     my ($type) = shift ;
651
652     filter_add(bless [] )
653 }
654
655 sub filter
656 {
657     my ($self) = @_ ;
658     my ($status) ;
659
660     if (($status = filter_read_exact(9)) > 0) {
661         s/HERE/THERE/g
662     }
663
664     $status ;
665 }
666
667 1 ;
668 EOM
669
670 writeFile($filenamebin, <<EOM, <<'EOM') ;
671 use $block ;
672 EOM
673 print "
674 HERE I am
675 I'm HERE
676 HERE today gone tomorrow\n" ;
677 EOM
678
679 $a = `$Perl "-I." $Inc $filenamebin  $redir` ;
680 ok(23, ($? >>8) == 0) ;
681 ok(24, $a eq <<EOM) ;
682
683 HERE I am
684 I'm THERE
685 THERE today gone tomorrow
686 EOM
687
688 {
689
690 # Check __DATA__
691 ####################
692
693 writeFile("${block}.pm", <<EOM, <<'EOM') ;
694 package ${block} ;
695 use Filter::Util::Call ;
696
697 EOM
698
699 sub import
700 {
701     my ($type) = shift ;
702
703     filter_add([])
704 }
705
706 sub filter
707 {
708     my ($self) = @_ ;
709     my ($status) ;
710
711     if (($status = filter_read()) > 0) {
712         s/HERE/THERE/g
713     }
714
715     $status ;
716 }
717
718 1 ;
719 EOM
720
721 writeFile($filename, <<EOM, <<'EOM') ;
722 use $block ;
723 EOM
724 print "HERE HERE\n";
725 @a = <DATA>;
726 print @a;
727 __DATA__
728 HERE I am
729 I'm HERE
730 HERE today gone tomorrow
731 EOM
732
733 $a = `$Perl "-I." $Inc $filename  $redir` ;
734 ok(25, ($? >>8) == 0) ;
735 ok(26, $a eq <<EOM) ;
736 THERE THERE
737 HERE I am
738 I'm HERE
739 HERE today gone tomorrow
740 EOM
741
742 }
743
744 {
745
746 # Check __END__
747 ####################
748
749 writeFile("${block}.pm", <<EOM, <<'EOM') ;
750 package ${block} ;
751 use Filter::Util::Call ;
752
753 EOM
754
755 sub import
756 {
757     my ($type) = shift ;
758
759     filter_add(bless [] )
760 }
761
762 sub filter
763 {
764     my ($self) = @_ ;
765     my ($status) ;
766
767     if (($status = filter_read()) > 0) {
768         s/HERE/THERE/g
769     }
770
771     $status ;
772 }
773
774 1 ;
775 EOM
776
777 writeFile($filename, <<EOM, <<'EOM') ;
778 use $block ;
779 EOM
780 print "HERE HERE\n";
781 @a = <DATA>;
782 print @a;
783 __END__
784 HERE I am
785 I'm HERE
786 HERE today gone tomorrow
787 EOM
788
789 $a = `$Perl "-I." $Inc $filename  $redir` ;
790 ok(27, ($? >>8) == 0) ;
791 ok(28, $a eq <<EOM) ;
792 THERE THERE
793 HERE I am
794 I'm HERE
795 HERE today gone tomorrow
796 EOM
797
798 }
799
800 {
801
802 # no without use
803 # see Message-ID: <2002110621.427.A15377@ttul.org>
804 ####################
805
806 writeFile("${module6}.pm", <<EOM);
807 package ${module6} ;
808 #use Filter::Simple;
809 #FILTER {}
810 use Filter::Util::Call;
811 sub import { filter_add(sub{}) }
812 sub unimport { filter_del() }
813 1;
814 EOM
815
816 writeFile($filename2, <<EOM);
817 no ${module6} ;
818 print "ok";
819 EOM
820
821 my $str = $^O eq 'MacOS' ? "'ok'" : "q{ok}";
822 my $a = `$Perl "-I." $Inc -e "no ${module6}; print $str"`;
823 ok(29, ($? >>8) == 0);
824 chomp( $a ) if $^O eq 'VMS';
825 ok(30, $a eq 'ok');
826
827 $a = `$Perl "-I." $Inc $filename2`;
828 ok(31, ($? >>8) == 0);
829 chomp( $a ) if $^O eq 'VMS';
830 ok(32, $a eq 'ok');
831
832 }
833
834 # error: filter_read_exact: size parameter must be > 0
835 ######################################
836
837 writeFile("${block}.pm", <<EOM, <<'EOM') ;
838 package ${block} ;
839 use Filter::Util::Call ;
840
841 EOM
842
843 sub import
844 {
845     my ($type) = shift ;
846     filter_add(bless [] )
847 }
848
849 sub filter
850 {
851     my ($self) = @_ ;
852     my ($status) ;
853     if (($status = filter_read_exact(0)) > 0) {
854         s/HERE/THERE/g
855     }
856     $status ;
857 }
858
859 1 ;
860 EOM
861
862 writeFile($filenamebin, <<EOM, <<'EOM') ;
863 use $block ;
864 EOM
865 print "
866 HERE I am
867 I'm HERE
868 HERE today gone tomorrow\n" ;
869 EOM
870
871 $a = `$Perl "-I." $Inc $filenamebin  $redir` ;
872 ok(33, ($? >>8) != 0) ;
873 ok(34, $a =~ /^filter_read_exact: size parameter must be > 0 at block.pm/) ;
874
875
876 END {
877     1 while unlink $filename ;
878     1 while unlink $filename2 ;
879     1 while unlink $filenamebin ;
880     1 while unlink "${module}.pm" ;
881     1 while unlink "${module2}.pm" ;
882     1 while unlink "${module3}.pm" ;
883     1 while unlink "${module4}.pm" ;
884     1 while unlink "${module5}.pm" ;
885     1 while unlink "${module6}.pm" ;
886     1 while unlink $nested ;
887     1 while unlink "${block}.pm" ;
888 }
889
890