]> git.donarmstrong.com Git - perltidy.git/blob - t/snippets18.t
67ca2647ab45b9fc710d1843759491ded97a8272
[perltidy.git] / t / snippets18.t
1 # Created with: ./make_t.pl
2
3 # Contents:
4 #1 wn7.wn
5 #2 wn8.def
6 #3 wn8.wn
7 #4 comments.comments5
8 #5 braces.braces1
9 #6 braces.braces2
10 #7 braces.braces3
11 #8 braces.def
12 #9 csc.csc1
13 #10 csc.csc2
14 #11 csc.def
15 #12 iob.def
16 #13 iob.iob
17 #14 kis.def
18 #15 kis.kis
19 #16 maths.def
20 #17 maths.maths1
21 #18 maths.maths2
22 #19 misc_tests.def
23
24 # To locate test #13 you can search for its name or the string '#13'
25
26 use strict;
27 use Test::More;
28 use Carp;
29 use Perl::Tidy;
30 my $rparams;
31 my $rsources;
32 my $rtests;
33
34 BEGIN {
35
36     ###########################################
37     # BEGIN SECTION 1: Parameter combinations #
38     ###########################################
39     $rparams = {
40         'braces1'   => "-bl -asbl",
41         'braces2'   => "-sbl",
42         'braces3'   => "-bli -bbvt=1",
43         'comments5' => <<'----------',
44 # testing --delete-side-comments and --nostatic-block-comments
45 -dsc -nsbc
46 ----------
47         'csc1'   => "-csc -csci=2 -ncscb",
48         'csc2'   => "-dcsc",
49         'def'    => "",
50         'iob'    => "-iob",
51         'kis'    => "-kis",
52         'maths1' => <<'----------',
53 # testing -break-before-all-operators and no spaces around math operators
54 -bbao -nwls="= + - / *"  -nwrs="= + - / *"
55 ----------
56         'maths2' => <<'----------',
57 # testing -break-after-all-operators and no spaces around math operators
58 -baao -nwls="= + - / *"  -nwrs="= + - / *"
59 ----------
60         'wn' => "-wn",
61     };
62
63     ############################
64     # BEGIN SECTION 2: Sources #
65     ############################
66     $rsources = {
67
68         'braces' => <<'----------',
69 sub message {
70     if ( !defined( $_[0] ) ) {
71         print("Hello, World\n");
72     }
73     else {
74         print( $_[0], "\n" );
75     }
76 }
77
78 $myfun = sub {
79     print("Hello, World\n");
80 };
81
82 eval {
83     my $app = App::perlbrew->new( "install-patchperl", "-q" );
84     $app->run();
85 } or do {
86     $error          = $@;
87     $produced_error = 1;
88 };
89
90 Mojo::IOLoop->next_tick(
91     sub {
92         $ua->get(
93             '/' => sub {
94                 push @kept_alive, pop->kept_alive;
95                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
96             }
97         );
98     }
99 );
100
101 $r = do {
102     sswitch( $words[ rand @words ] ) {
103         case $words[0]:
104         case $words[1]:
105         case $words[2]:
106         case $words[3]: { 'ok' }
107       default: { 'wtf' }
108     }
109 };
110
111 try {
112     die;
113 }
114 catch {
115     die;
116 };
117 ----------
118
119         'comments' => <<'----------',
120 #!/usr/bin/perl -w
121 # an initial hash bang line cannot be deleted with -dp
122 #<<< format skipping of first code can cause an error message in perltidy v20210625
123 my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
124 #>>>
125 sub length { return length($_[0]) }    # side comment
126                              # hanging side comment
127                              # very longgggggggggggggggggggggggggggggggggggggggggggggggggggg hanging side comment
128
129 # a blank will be inserted to prevent forming a hanging side comment
130 sub macro_get_names { #
131
132 # %name = macro_get_names();  (key=macrohandle, value=macroname)
133 #
134 ##local(%name);  # a static block comment without indentation
135    local(%name)=();  ## a static side comment to test -ssc
136
137  # a spaced block comment to test -isbc
138    for (0..$#mac_ver) {
139       # a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
140       $name{$_} = $mac_ext[$idx{$mac_exti[$_]}];
141       $vmsfile =~ s/;[\d\-]*$//; # very long side comment; Clip off version number; we can use a newer version as well
142
143    }
144    %name;
145
146
147
148
149     @month_of_year = ( 
150         'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
151     ##  'Dec', 'Nov'   [a static block comment with indentation]
152         'Nov', 'Dec');
153
154
155 {    # this side comment will not align
156     my $IGNORE = 0;    # This is a side comment
157                        # This is a hanging side comment
158                        # And so is this
159
160     # A blank line interrupts the hsc's; this is a block comment
161
162 }
163
164 # side comments at different indentation levels should not normally be aligned
165 { { { { { ${msg} = "Hello World!"; print "My message: ${msg}\n"; } } #end level 4
166         } # end level 3
167     } # end level 2
168 } # end level 1
169
170
171 #<<<  do not let perltidy touch this unless -nfs is set
172     my @list = (1,
173                 1, 1,
174                 1, 2, 1,
175                 1, 3, 3, 1,
176                 1, 4, 6, 4, 1,);
177 #>>>
178
179 #<<  test alternate format skipping string
180     my @list = (1,
181                 1, 1,
182                 1, 2, 1,
183                 1, 3, 3, 1,
184                 1, 4, 6, 4, 1,);
185 #>>
186
187
188
189 # some blank lines follow
190
191
192
193 =pod
194 Some pod before __END__ to delete with -dp
195 =cut
196
197
198 __END__
199
200
201 # text following __END__, not a comment
202
203
204 =pod
205 Some pod after __END__ to delete with -dp and trim with -trp     
206 =cut
207
208
209 ----------
210
211         'csc' => <<'----------',
212         sub message {
213             if ( !defined( $_[0] ) ) {
214                 print("Hello, World\n");
215             }
216             else {
217                 print( $_[0], "\n" );
218             }
219         } ## end sub message
220 ----------
221
222         'iob' => <<'----------',
223 return "this is a descriptive error message"
224   if $res->is_error
225   or not length $data;
226 ----------
227
228         'kis' => <<'----------',
229     dbmclose(%verb_delim); undef %verb_delim;
230     dbmclose(%expanded); undef %expanded;
231 ----------
232
233         'maths' => <<'----------',
234 $tmp = $day - 32075 + 1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 + 367
235 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 - 3 * ( ( $year + 4900 -
236 ( 14 - $month ) / 12 ) / 100 ) / 4;
237
238 return ( $r**$n ) * ( pi**( $n / 2 ) ) / ( sqrt(pi) * factorial( 2 * ( int( $n
239 / 2 ) ) + 2 ) / factorial( int( $n / 2 ) + 1 ) / ( 4**( int( $n / 2 ) + 1 ) )
240 );
241
242 $root=-$b+sqrt($b*$b-4.*$a*$c)/(2.*$a);
243 ----------
244
245         'misc_tests' => <<'----------',
246 for ( @a = @$ap, $u = shift @a; @a; $u = $v ) { ... } # test -sfs 
247 $i = 1 ;     #  test -sts
248 $i = 0;    ##  =1;  test -ssc
249 ;;;; # test -ndsm
250 my ( $a, $b, $c ) = @_;    # test -nsak="my for"
251 ----------
252
253         'wn7' => <<'----------',
254                     # do not weld paren to opening one-line non-paren container
255                     $Self->_Add($SortOrderDisplay{$Field->GenerateFieldForSelectSQL()});
256
257                     # this will not get welded with -wn
258                     f(
259                       do { 1; !!(my $x = bless []); }
260                     );
261 ----------
262
263         'wn8' => <<'----------',
264             # Former -wn blinkers, which oscillated between two states
265
266             # fixed RULE 1 only applies to '('
267             my $res = eval { { $die_on_fetch, 0 } };
268
269             my $res = eval {
270                 { $die_on_fetch, 0 }
271             };
272
273             # fixed RULE 2 applies to any inner opening token; this is a stable
274             # state with -wn
275             $app->FORM->{'appbar1'}->set_status(
276                 _("Cannot delete zone $name: sub-zones or appellations exist.")
277             );
278
279             # OLD: fixed RULE 1: this is now a stable state with -wn
280             # NEW (30 jan 2021): do not weld if one interior token
281             $app->FORM->{'appbar1'}->set_status(_(
282                  "Cannot delete zone $name: sub-zones or appellations exist."));
283 ----------
284     };
285
286     ####################################
287     # BEGIN SECTION 3: Expected output #
288     ####################################
289     $rtests = {
290
291         'wn7.wn' => {
292             source => "wn7",
293             params => "wn",
294             expect => <<'#1...........',
295                     # do not weld paren to opening one-line non-paren container
296                     $Self->_Add(
297                         $SortOrderDisplay{
298                             $Field->GenerateFieldForSelectSQL()
299                         }
300                     );
301
302                     # this will not get welded with -wn
303                     f(
304                         do { 1; !!( my $x = bless [] ); }
305                     );
306 #1...........
307         },
308
309         'wn8.def' => {
310             source => "wn8",
311             params => "def",
312             expect => <<'#2...........',
313             # Former -wn blinkers, which oscillated between two states
314
315             # fixed RULE 1 only applies to '('
316             my $res = eval {
317                 { $die_on_fetch, 0 }
318             };
319
320             my $res = eval {
321                 { $die_on_fetch, 0 }
322             };
323
324             # fixed RULE 2 applies to any inner opening token; this is a stable
325             # state with -wn
326             $app->FORM->{'appbar1'}->set_status(
327                 _("Cannot delete zone $name: sub-zones or appellations exist.")
328             );
329
330             # OLD: fixed RULE 1: this is now a stable state with -wn
331             # NEW (30 jan 2021): do not weld if one interior token
332             $app->FORM->{'appbar1'}->set_status(
333                 _("Cannot delete zone $name: sub-zones or appellations exist.")
334             );
335 #2...........
336         },
337
338         'wn8.wn' => {
339             source => "wn8",
340             params => "wn",
341             expect => <<'#3...........',
342             # Former -wn blinkers, which oscillated between two states
343
344             # fixed RULE 1 only applies to '('
345             my $res = eval { { $die_on_fetch, 0 } };
346
347             my $res = eval {
348                 { $die_on_fetch, 0 }
349             };
350
351             # fixed RULE 2 applies to any inner opening token; this is a stable
352             # state with -wn
353             $app->FORM->{'appbar1'}->set_status(
354                 _("Cannot delete zone $name: sub-zones or appellations exist.")
355             );
356
357             # OLD: fixed RULE 1: this is now a stable state with -wn
358             # NEW (30 jan 2021): do not weld if one interior token
359             $app->FORM->{'appbar1'}->set_status(
360                 _("Cannot delete zone $name: sub-zones or appellations exist.")
361             );
362 #3...........
363         },
364
365         'comments.comments5' => {
366             source => "comments",
367             params => "comments5",
368             expect => <<'#4...........',
369 #!/usr/bin/perl -w
370 # an initial hash bang line cannot be deleted with -dp
371 #<<< format skipping of first code can cause an error message in perltidy v20210625
372 my $rvar = [ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
373 #>>>
374 sub length { return length( $_[0] ) }
375
376 # a blank will be inserted to prevent forming a hanging side comment
377 sub macro_get_names {
378     #
379     # %name = macro_get_names();  (key=macrohandle, value=macroname)
380     #
381     ##local(%name);  # a static block comment without indentation
382     local (%name) = ();
383
384     # a spaced block comment to test -isbc
385     for ( 0 .. $#mac_ver ) {
386
387 # a very long comment for testing the parameter --nooutdent-long-comments (or -nolc)
388         $name{$_} = $mac_ext[ $idx{ $mac_exti[$_] } ];
389         $vmsfile =~ s/;[\d\-]*$//;
390
391     }
392     %name;
393 }
394
395 @month_of_year = (
396     'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
397
398     ##  'Dec', 'Nov'   [a static block comment with indentation]
399     'Nov', 'Dec'
400 );
401
402 {
403     my $IGNORE = 0;
404
405     # A blank line interrupts the hsc's; this is a block comment
406
407 }
408
409 # side comments at different indentation levels should not normally be aligned
410 {
411     {
412         {
413             {
414                 { ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
415             }
416         }
417     }
418 }
419
420 #<<<  do not let perltidy touch this unless -nfs is set
421     my @list = (1,
422                 1, 1,
423                 1, 2, 1,
424                 1, 3, 3, 1,
425                 1, 4, 6, 4, 1,);
426 #>>>
427
428 #<<  test alternate format skipping string
429 my @list = ( 1, 1, 1, 1, 2, 1, 1, 3, 3, 1, 1, 4, 6, 4, 1, );
430
431 #>>
432
433 # some blank lines follow
434
435 =pod
436 Some pod before __END__ to delete with -dp
437 =cut
438
439 __END__
440
441
442 # text following __END__, not a comment
443
444
445 =pod
446 Some pod after __END__ to delete with -dp and trim with -trp     
447 =cut
448
449
450 #4...........
451         },
452
453         'braces.braces1' => {
454             source => "braces",
455             params => "braces1",
456             expect => <<'#5...........',
457 sub message
458 {
459     if ( !defined( $_[0] ) )
460     {
461         print("Hello, World\n");
462     }
463     else
464     {
465         print( $_[0], "\n" );
466     }
467 }
468
469 $myfun = sub
470 {
471     print("Hello, World\n");
472 };
473
474 eval {
475     my $app = App::perlbrew->new( "install-patchperl", "-q" );
476     $app->run();
477 } or do
478 {
479     $error          = $@;
480     $produced_error = 1;
481 };
482
483 Mojo::IOLoop->next_tick(
484     sub
485     {
486         $ua->get(
487             '/' => sub
488             {
489                 push @kept_alive, pop->kept_alive;
490                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
491             }
492         );
493     }
494 );
495
496 $r = do
497 {
498     sswitch( $words[ rand @words ] )
499     {
500         case $words[0]:
501         case $words[1]:
502         case $words[2]:
503         case $words[3]: { 'ok' }
504       default: { 'wtf' }
505     }
506 };
507
508 try
509 {
510     die;
511 }
512 catch
513 {
514     die;
515 };
516 #5...........
517         },
518
519         'braces.braces2' => {
520             source => "braces",
521             params => "braces2",
522             expect => <<'#6...........',
523 sub message
524 {
525     if ( !defined( $_[0] ) ) {
526         print("Hello, World\n");
527     }
528     else {
529         print( $_[0], "\n" );
530     }
531 }
532
533 $myfun = sub {
534     print("Hello, World\n");
535 };
536
537 eval {
538     my $app = App::perlbrew->new( "install-patchperl", "-q" );
539     $app->run();
540 } or do {
541     $error          = $@;
542     $produced_error = 1;
543 };
544
545 Mojo::IOLoop->next_tick(
546     sub {
547         $ua->get(
548             '/' => sub {
549                 push @kept_alive, pop->kept_alive;
550                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
551             }
552         );
553     }
554 );
555
556 $r = do {
557     sswitch( $words[ rand @words ] ) {
558         case $words[0]:
559         case $words[1]:
560         case $words[2]:
561         case $words[3]: { 'ok' }
562       default: { 'wtf' }
563     }
564 };
565
566 try {
567     die;
568 }
569 catch {
570     die;
571 };
572 #6...........
573         },
574
575         'braces.braces3' => {
576             source => "braces",
577             params => "braces3",
578             expect => <<'#7...........',
579 sub message
580   { if ( !defined( $_[0] ) )
581       { print("Hello, World\n");
582       }
583     else
584       { print( $_[0], "\n" );
585       }
586   }
587
588 $myfun = sub {
589     print("Hello, World\n");
590 };
591
592 eval {
593     my $app = App::perlbrew->new( "install-patchperl", "-q" );
594     $app->run();
595 } or do
596   { $error          = $@;
597     $produced_error = 1;
598   };
599
600 Mojo::IOLoop->next_tick(
601     sub {
602         $ua->get(
603             '/' => sub {
604                 push @kept_alive, pop->kept_alive;
605                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
606             }
607         );
608     }
609 );
610
611 $r = do
612   { sswitch( $words[ rand @words ] )
613     {
614         case $words[0]:
615         case $words[1]:
616         case $words[2]:
617         case $words[3]: { 'ok' }
618       default: { 'wtf' }
619     }
620   };
621
622 try
623 {
624     die;
625 }
626 catch
627 {
628     die;
629 };
630 #7...........
631         },
632
633         'braces.def' => {
634             source => "braces",
635             params => "def",
636             expect => <<'#8...........',
637 sub message {
638     if ( !defined( $_[0] ) ) {
639         print("Hello, World\n");
640     }
641     else {
642         print( $_[0], "\n" );
643     }
644 }
645
646 $myfun = sub {
647     print("Hello, World\n");
648 };
649
650 eval {
651     my $app = App::perlbrew->new( "install-patchperl", "-q" );
652     $app->run();
653 } or do {
654     $error          = $@;
655     $produced_error = 1;
656 };
657
658 Mojo::IOLoop->next_tick(
659     sub {
660         $ua->get(
661             '/' => sub {
662                 push @kept_alive, pop->kept_alive;
663                 Mojo::IOLoop->next_tick( sub { Mojo::IOLoop->stop } );
664             }
665         );
666     }
667 );
668
669 $r = do {
670     sswitch( $words[ rand @words ] ) {
671         case $words[0]:
672         case $words[1]:
673         case $words[2]:
674         case $words[3]: { 'ok' }
675       default: { 'wtf' }
676     }
677 };
678
679 try {
680     die;
681 }
682 catch {
683     die;
684 };
685 #8...........
686         },
687
688         'csc.csc1' => {
689             source => "csc",
690             params => "csc1",
691             expect => <<'#9...........',
692         sub message {
693             if ( !defined( $_[0] ) ) {
694                 print("Hello, World\n");
695             } ## end if ( !defined( $_[0] ))
696             else {
697                 print( $_[0], "\n" );
698             } ## end else [ if ( !defined( $_[0] ))
699         } ## end sub message
700 #9...........
701         },
702
703         'csc.csc2' => {
704             source => "csc",
705             params => "csc2",
706             expect => <<'#10...........',
707         sub message {
708             if ( !defined( $_[0] ) ) {
709                 print("Hello, World\n");
710             }
711             else {
712                 print( $_[0], "\n" );
713             }
714         }
715 #10...........
716         },
717
718         'csc.def' => {
719             source => "csc",
720             params => "def",
721             expect => <<'#11...........',
722         sub message {
723             if ( !defined( $_[0] ) ) {
724                 print("Hello, World\n");
725             }
726             else {
727                 print( $_[0], "\n" );
728             }
729         } ## end sub message
730 #11...........
731         },
732
733         'iob.def' => {
734             source => "iob",
735             params => "def",
736             expect => <<'#12...........',
737 return "this is a descriptive error message"
738   if $res->is_error
739   or not length $data;
740 #12...........
741         },
742
743         'iob.iob' => {
744             source => "iob",
745             params => "iob",
746             expect => <<'#13...........',
747 return "this is a descriptive error message"
748   if $res->is_error or not length $data;
749 #13...........
750         },
751
752         'kis.def' => {
753             source => "kis",
754             params => "def",
755             expect => <<'#14...........',
756     dbmclose(%verb_delim);
757     undef %verb_delim;
758     dbmclose(%expanded);
759     undef %expanded;
760 #14...........
761         },
762
763         'kis.kis' => {
764             source => "kis",
765             params => "kis",
766             expect => <<'#15...........',
767     dbmclose(%verb_delim); undef %verb_delim;
768     dbmclose(%expanded);   undef %expanded;
769 #15...........
770         },
771
772         'maths.def' => {
773             source => "maths",
774             params => "def",
775             expect => <<'#16...........',
776 $tmp =
777   $day - 32075 +
778   1461 * ( $year + 4800 - ( 14 - $month ) / 12 ) / 4 +
779   367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 -
780   3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4;
781
782 return ( $r**$n ) *
783   ( pi**( $n / 2 ) ) /
784   (
785     sqrt(pi) *
786       factorial( 2 * ( int( $n / 2 ) ) + 2 ) /
787       factorial( int( $n / 2 ) + 1 ) /
788       ( 4**( int( $n / 2 ) + 1 ) ) );
789
790 $root = -$b + sqrt( $b * $b - 4. * $a * $c ) / ( 2. * $a );
791 #16...........
792         },
793
794         'maths.maths1' => {
795             source => "maths",
796             params => "maths1",
797             expect => <<'#17...........',
798 $tmp
799   =$day-32075
800   +1461*( $year+4800-( 14-$month )/12 )/4
801   +367*( $month-2+( ( 14-$month )/12 )*12 )/12
802   -3*( ( $year+4900-( 14-$month )/12 )/100 )/4;
803
804 return ( $r**$n )
805   *( pi**( $n/2 ) )
806   /(
807     sqrt(pi)
808       *factorial( 2*( int( $n/2 ) )+2 )
809       /factorial( int( $n/2 )+1 )
810       /( 4**( int( $n/2 )+1 ) ) );
811
812 $root=-$b+sqrt( $b*$b-4.*$a*$c )/( 2.*$a );
813 #17...........
814         },
815
816         'maths.maths2' => {
817             source => "maths",
818             params => "maths2",
819             expect => <<'#18...........',
820 $tmp=
821   $day-32075+
822   1461*( $year+4800-( 14-$month )/12 )/4+
823   367*( $month-2+( ( 14-$month )/12 )*12 )/12-
824   3*( ( $year+4900-( 14-$month )/12 )/100 )/4;
825
826 return ( $r**$n )*
827   ( pi**( $n/2 ) )/
828   (
829     sqrt(pi)*
830       factorial( 2*( int( $n/2 ) )+2 )/
831       factorial( int( $n/2 )+1 )/
832       ( 4**( int( $n/2 )+1 ) ) );
833
834 $root=-$b+sqrt( $b*$b-4.*$a*$c )/( 2.*$a );
835 #18...........
836         },
837
838         'misc_tests.def' => {
839             source => "misc_tests",
840             params => "def",
841             expect => <<'#19...........',
842 for ( @a = @$ap, $u = shift @a ; @a ; $u = $v ) { ... }    # test -sfs
843 $i = 1;                                                    #  test -sts
844 $i = 0;                                                    ##  =1;  test -ssc
845 ;                                                          # test -ndsm
846 my ( $a, $b, $c ) = @_;                                    # test -nsak="my for"
847 #19...........
848         },
849     };
850
851     my $ntests = 0 + keys %{$rtests};
852     plan tests => $ntests;
853 }
854
855 ###############
856 # EXECUTE TESTS
857 ###############
858
859 foreach my $key ( sort keys %{$rtests} ) {
860     my $output;
861     my $sname  = $rtests->{$key}->{source};
862     my $expect = $rtests->{$key}->{expect};
863     my $pname  = $rtests->{$key}->{params};
864     my $source = $rsources->{$sname};
865     my $params = defined($pname) ? $rparams->{$pname} : "";
866     my $stderr_string;
867     my $errorfile_string;
868     my $err = Perl::Tidy::perltidy(
869         source      => \$source,
870         destination => \$output,
871         perltidyrc  => \$params,
872         argv        => '',             # for safety; hide any ARGV from perltidy
873         stderr      => \$stderr_string,
874         errorfile   => \$errorfile_string,    # not used when -se flag is set
875     );
876     if ( $err || $stderr_string || $errorfile_string ) {
877         print STDERR "Error output received for test '$key'\n";
878         if ($err) {
879             print STDERR "An error flag '$err' was returned\n";
880             ok( !$err );
881         }
882         if ($stderr_string) {
883             print STDERR "---------------------\n";
884             print STDERR "<<STDERR>>\n$stderr_string\n";
885             print STDERR "---------------------\n";
886             ok( !$stderr_string );
887         }
888         if ($errorfile_string) {
889             print STDERR "---------------------\n";
890             print STDERR "<<.ERR file>>\n$errorfile_string\n";
891             print STDERR "---------------------\n";
892             ok( !$errorfile_string );
893         }
894     }
895     else {
896         if ( !is( $output, $expect, $key ) ) {
897             my $leno = length($output);
898             my $lene = length($expect);
899             if ( $leno == $lene ) {
900                 print STDERR
901 "#> Test '$key' gave unexpected output.  Strings differ but both have length $leno\n";
902             }
903             else {
904                 print STDERR
905 "#> Test '$key' gave unexpected output.  String lengths differ: output=$leno, expected=$lene\n";
906             }
907         }
908     }
909 }