[p5sagit/p5-mst-13.2.git] / t / op / write.t

#!./perl

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
}

#-- testing numeric fields in all variants (WL)

sub swrite {
    my $format = shift;
    local $^A = ""; # don't litter, use a local bin
    formline( $format, @_ );
    return $^A;
}

my @NumTests = (
    [ '@###',   0, 1, 9999.5, 9999.4999, -999.5, 1e100 ],
    [ '@0##',   0, 1, 9999.5, -999.4999, -999.5, 1e100 ],
    [ '^###',   0, undef ],
    [ '^0##',   0, undef ],
    [ '@###.',  0, 1, 9999.5, 9999.4999, -999.5 ],
    [ '@##.##', 0, 1, 999.995, 999.99499, -100 ],
    [ '@0#.##', 0, 1, 10, -0.0001 ],
	    );

sub mkfmt($){
    my $fmt = shift();
    my $fieldwidth = length( $fmt );
    my $leadzero = $fmt =~ /^.0/ ? "0" : "";
    if( $fmt =~ /\.(#*)/ ){
        my $fractwidth = length( $1 );
        return "%#${leadzero}${fieldwidth}.${fractwidth}f"
    } else {
        return "%${leadzero}${fieldwidth}.0f"
    }
} 

my $num_tests = 0;
for my $tref ( @NumTests ){
    $num_tests += @$tref - 1;
}
#---------------------------------------------------------

# number of tests in section 1
my $bas_tests = 20;

# number of tests in section 3
my $hmb_tests = 36;

printf "1..%d\n", $bas_tests + $num_tests + $hmb_tests;

my $CAT = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') ? 'type'
	: ($^O eq 'MacOS') ? 'catenate'
        : 'cat';

############
## Section 1
############

format OUT =
the quick brown @<<
$fox
jumped
@*
$multiline
^<<<<<<<<<
$foo
^<<<<<<<<<
$foo
^<<<<<<...
$foo
now @<<the@>>>> for all@|||||men to come @<<<<
{
    'i' . 's', "time\n", $good, 'to'
}
.

open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
END { 1 while unlink 'Op_write.tmp' }

$fox = 'foxiness';
$good = 'good';
$multiline = "forescore\nand\nseven years\n";
$foo = 'when in the course of human events it becomes necessary';
write(OUT);
close OUT or die "Could not close: $!";

$right =
"the quick brown fox
jumped
forescore
and
seven years
when in
the course
of huma...
now is the time for all good men to come to\n";

if (`$CAT Op_write.tmp` eq $right)
    { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
else
    { print "not ok 1\n"; }

$fox = 'wolfishness';
my $fox = 'foxiness';		# Test a lexical variable.

format OUT2 =
the quick brown @<<
$fox
jumped
@*
$multiline
^<<<<<<<<< ~~
$foo
now @<<the@>>>> for all@|||||men to come @<<<<
'i' . 's', "time\n", $good, 'to'
.

open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";

$good = 'good';
$multiline = "forescore\nand\nseven years\n";
$foo = 'when in the course of human events it becomes necessary';
write(OUT2);
close OUT2 or die "Could not close: $!";

$right =
"the quick brown fox
jumped
forescore
and
seven years
when in
the course
of human
events it
becomes
necessary
now is the time for all good men to come to\n";

if (`$CAT Op_write.tmp` eq $right)
    { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
else
    { print "not ok 2\n"; }

eval <<'EOFORMAT';
format OUT2 =
the brown quick @<<
$fox
jumped
@*
$multiline
and
^<<<<<<<<< ~~
$foo
now @<<the@>>>> for all@|||||men to come @<<<<
'i' . 's', "time\n", $good, 'to'
.
EOFORMAT

open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";

$fox = 'foxiness';
$good = 'good';
$multiline = "forescore\nand\nseven years\n";
$foo = 'when in the course of human events it becomes necessary';
write(OUT2);
close OUT2 or die "Could not close: $!";

$right =
"the brown quick fox
jumped
forescore
and
seven years
and
when in
the course
of human
events it
becomes
necessary
now is the time for all good men to come to\n";

if (`$CAT Op_write.tmp` eq $right)
    { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
else
    { print "not ok 3\n"; }

# formline tests

$mustbe = <<EOT;
@ a
@> ab
@>> abc
@>>>  abc
@>>>>   abc
@>>>>>    abc
@>>>>>>     abc
@>>>>>>>      abc
@>>>>>>>>       abc
@>>>>>>>>>        abc
@>>>>>>>>>>         abc
EOT

$was1 = $was2 = '';
for (0..10) {           
  # lexical picture
  $^A = '';
  my $format1 = '@' . '>' x $_;
  formline $format1, 'abc';
  $was1 .= "$format1 $^A\n";
  # global
  $^A = '';
  local $format2 = '@' . '>' x $_;
  formline $format2, 'abc';
  $was2 .= "$format2 $^A\n";
}
print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";

$^A = '';

# more test

format OUT3 =
^<<<<<<...
$foo
.

open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";

$foo = 'fit          ';
write(OUT3);
close OUT3 or die "Could not close: $!";

$right =
"fit\n";

if (`$CAT Op_write.tmp` eq $right)
    { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
else
    { print "not ok 6\n"; }

# test lexicals and globals
{
    my $this = "ok";
    our $that = 7;
    format LEX =
@<<@|
$this,$that
.
    open(LEX, ">&STDOUT") or die;
    write LEX;
    $that = 8;
    write LEX;
    close LEX or die "Could not close: $!";
}
# LEX_INTERPNORMAL test
my %e = ( a => 1 );
format OUT4 =
@<<<<<<
"$e{a}"
.
open   OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
write (OUT4);
close  OUT4 or die "Could not close: $!";
if (`$CAT Op_write.tmp` eq "1\n") {
    print "ok 9\n";
    1 while unlink "Op_write.tmp";
    }
else {
    print "not ok 9\n";
    }

eval <<'EOFORMAT';
format OUT10 =
@####.## @0###.##
$test1, $test1
.
EOFORMAT

open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";

$test1 = 12.95;
write(OUT10);
close OUT10 or die "Could not close: $!";

$right = "   12.95 00012.95\n";
if (`$CAT Op_write.tmp` eq $right)
    { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
else
    { print "not ok 10\n"; }

eval <<'EOFORMAT';
format OUT11 =
@0###.## 
$test1
@ 0#
$test1
@0 # 
$test1
.
EOFORMAT

open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";

$test1 = 12.95;
write(OUT11);
close OUT11 or die "Could not close: $!";

$right = 
"00012.95
1 0#
10 #\n";
if (`$CAT Op_write.tmp` eq $right)
    { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
else
    { print "not ok 11\n"; }

{
    my $el;
    format OUT12 =
ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
$el
.
    my %hash = (12 => 3);
    open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp";

    for $el (keys %hash) {
	write(OUT12);
    }
    close OUT12 or die "Could not close: $!";
    print `$CAT Op_write.tmp`;

}

{
    # Bug report and testcase by Alexey Tourbin
    use Tie::Scalar;
    my $v;
    tie $v, 'Tie::StdScalar';
    $v = 13;
    format OUT13 =
ok ^<<<<<<<<< ~~
$v
.
    open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
    write(OUT13);
    close OUT13 or die "Could not close: $!";
    print `$CAT Op_write.tmp`;
}

{   # test 14
    # Bug #24774 format without trailing \n failed assertion, but this
    # must fail since we have a trailing ; in the eval'ed string (WL)
    my @v = ('k');
    eval "format OUT14 = \n@\n\@v";
    print $@ ? "ok 14\n" : "not ok 14\n";

}

{   # test 15
    # text lost in ^<<< field with \r in value (WL)
    my $txt = "line 1\rline 2";
    format OUT15 =
^<<<<<<<<<<<<<<<<<<
$txt
^<<<<<<<<<<<<<<<<<<
$txt
.
    open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
    write(OUT15);
    close OUT15 or die "Could not close: $!";
    my $res = `$CAT Op_write.tmp`;
    print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n";
}

{   # test 16: multiple use of a variable in same line with ^<
    my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
    format OUT16 =
^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
$txt,             $txt
^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
$txt,             $txt
.
    open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
    write(OUT16);
    close OUT16 or die "Could not close: $!";
    my $res = `$CAT Op_write.tmp`;
    print $res eq <<EOD ? "ok 16\n" : "not ok 16\n";
this_is_block_1   this_is_block_2
this_is_block_3   this_is_block_4
EOD
}

{   # test 17: @* "should be on a line of its own", but it should work
    # cleanly with literals before and after. (WL)

    my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
    format OUT17 =
Here we go: @* That's all, folks!
            $txt
.
    open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
    write(OUT17);
    close OUT17 or die "Could not close: $!";
    my $res = `$CAT Op_write.tmp`;
    chomp( $txt );
    my $exp = <<EOD;
Here we go: $txt That's all, folks!
EOD
    print $res eq $exp ? "ok 17\n" : "not ok 17\n";
}

{   # test 18: @# and ~~ would cause runaway format, but we now
    # catch this while compiling (WL)

    format OUT18 =
@######## ~~
10
.
    open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
    eval { write(OUT18); };
    print $@ ? "ok 18\n" : "not ok 18\n";
    close OUT18 or die "Could not close: $!";
}

{   # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
    my $v = 'gaga';
    eval "format OUT19 = \n" .
         '@<<<' . "\0\n" .
         '$v' .   "\n" .
         '@<<<' . "\0\n" .
         '$v' . "\n.\n";
    open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
    write(OUT19);
    my $res = `$CAT Op_write.tmp`;
    print $res eq <<EOD ? "ok 19\n" : "not ok 19\n";
gaga\0
gaga\0
EOD
}

{   # test 20: hash accesses; single '}' must not terminate format '}' (WL)
    my %h = ( xkey => 'xval', ykey => 'yval' );
    format OUT20 =
@>>>> @<<<< ~~
each %h
@>>>> @<<<<
$h{xkey}, $h{ykey}
@>>>> @<<<<
{ $h{xkey}, $h{ykey}
}
}
.
    my $exp = '';
    while( my( $k, $v ) = each( %h ) ){
	$exp .= sprintf( "%5s %s\n", $k, $v );
    }
    $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
    $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
    $exp .= "}\n";
    open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
    write(OUT20);
    my $res = `$CAT Op_write.tmp`;
    print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n";

EOD
}


#####################
## Section 2
## numeric formatting
#####################

my $nt = $bas_tests;
for my $tref ( @NumTests ){
    my $writefmt = shift( @$tref );
    my $printfmt = mkfmt( $writefmt );
    my $blank_when_undef = substr( $writefmt, 0, 1 ) eq '^';
    for my $val ( @$tref ){
        my $writeres = swrite( $writefmt, $val );
        my $printres;
        if( $blank_when_undef && ! defined($val) ){
            $printres = ' ' x length( $writefmt );
        } else {
            $printres = sprintf( $printfmt, $val || 0 );
            if( length($printres) > length( $writefmt ) ){
                $printres = '#' x length( $writefmt );
            }
        }
        $nt++;

        print $printres eq $writeres ? "ok $nt\n" : "not ok $nt\n";
    }
}


#####################################
## Section 3
## Easiest to add new tests above here
#######################################

# scary format testing from H.Merijn Brand

my $test = $bas_tests + $num_tests + 1;
my $tests = $bas_tests + $num_tests + $hmb_tests;

if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
    ($^O eq 'os2' and not eval '$OS2::can_fork')) {
  foreach ($test..$tests) {
      print "ok $_ # skipped: '|-' and '-|' not supported\n";
  }
  exit(0);
}


use strict;	# Amazed that this hackery can be made strict ...

# Just a complete test for format, including top-, left- and bottom marging
# and format detection through glob entries

format EMPTY =
.

format Comment =
ok @<<<<<
$test
.


# [ID 20020227.005] format bug with undefined _TOP

open STDOUT_DUP, ">&STDOUT";
my $oldfh = select STDOUT_DUP;
$= = 10;
{   local $~ = "Comment";
    write;
    $test++;
    print $- == 9
	? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
    $test++;
    print $^ eq "STDOUT_DUP_TOP"
	? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
    $test++;
}
select $oldfh;

$^  = "STDOUT_TOP";
$=  =  7;		# Page length
$-  =  0;		# Lines left
my $ps = $^L; $^L = "";	# Catch the page separator
my $tm =  1;		# Top margin (empty lines before first output)
my $bm =  2;		# Bottom marging (empty lines between last text and footer)
my $lm =  4;		# Left margin (indent in spaces)

select ((select (STDOUT), $| = 1)[0]);
if ($lm > 0 and !open STDOUT, "|-") {	# Left margin (in this test ALWAYS set)
    select ((select (STDOUT), $| = 1)[0]);
    my $s = " " x $lm;
    while (<STDIN>) {
	s/^/$s/;
	print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
	}
    close STDIN;
    print + (<DATA>?"not ":""), "ok ", $test++, "\n";
    close STDOUT;
    exit;
    }
$tm = "\n" x $tm;
$= -= $bm + 1; # count one for the trailing "----"
my $lastmin = 0;

my @E;

sub wryte
{
    $lastmin = $-;
    write;
    } # wryte;

sub footer
{
    $% == 1 and return "";

    $lastmin < $= and print "\n" x $lastmin;
    print "\n" x $bm, "----\n", $ps;
    $lastmin = $-;
    "";
    } # footer

# Yes, this is sick ;-)
format TOP =
@* ~
@{[footer]}
@* ~
$tm
.

format ENTRY =
@ @<<<<~~
@{(shift @E)||["",""]}
.

format EOR =
- -----
.

sub has_format ($)
{
    my $fmt = shift;
    exists $::{$fmt} or return 0;
    $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
    open my $null, "> /dev/null" or die;
    my $fh = select $null;
    local $~ = $fmt;
    eval "write";
    select $fh;
    $@?0:1;
    } # has_format

$^ = has_format ("TOP") ? "TOP" : "EMPTY";
has_format ("ENTRY") or die "No format defined for ENTRY";
foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
		[ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
    @E = @$e;
    local $~ = "ENTRY";
    wryte;
    has_format ("EOR") or next;
    local $~ = "EOR";
    wryte;
    }
if (has_format ("EOF")) {
    local $~ = "EOF";
    wryte;
    }

close STDOUT;

# That was test 48.

__END__
    
    1 Test1
    2 Test2
    3 Test3
    
    
    ----
    \f
    4 Test4
    5 Test5
    6 Test6
    
    
    ----
    \f
    7 Test7
    - -----
    
    
    ----
    \f
    1 1tseT
    2 2tseT
    3 3tseT
    
    
    ----
    \f
    4 4tseT
    5 5tseT
    - -----
Commit	Line	Data
a687059c	1	#!./perl
a687059c	2
9ccde9ea	3	BEGIN {
	4	chdir 't' if -d 't';
	5	@INC = '../lib';
	6	}
	7
a1b95068	8	#-- testing numeric fields in all variants (WL)
	9
	10	sub swrite {
	11	my $format = shift;
	12	local $^A = ""; # don't litter, use a local bin
	13	formline( $format, @_ );
	14	return $^A;
	15	}
	16
	17	my @NumTests = (
	18	[ '@###', 0, 1, 9999.5, 9999.4999, -999.5, 1e100 ],
	19	[ '@0##', 0, 1, 9999.5, -999.4999, -999.5, 1e100 ],
	20	[ '^###', 0, undef ],
	21	[ '^0##', 0, undef ],
	22	[ '@###.', 0, 1, 9999.5, 9999.4999, -999.5 ],
	23	[ '@##.##', 0, 1, 999.995, 999.99499, -100 ],
	24	[ '@0#.##', 0, 1, 10, -0.0001 ],
	25	);
	26
	27	sub mkfmt($){
	28	my $fmt = shift();
	29	my $fieldwidth = length( $fmt );
	30	my $leadzero = $fmt =~ /^.0/ ? "0" : "";
	31	if( $fmt =~ /\.(#*)/ ){
	32	my $fractwidth = length( $1 );
	33	return "%#${leadzero}${fieldwidth}.${fractwidth}f"
	34	} else {
	35	return "%${leadzero}${fieldwidth}.0f"
	36	}
	37	}
	38
	39	my $num_tests = 0;
	40	for my $tref ( @NumTests ){
	41	$num_tests += @$tref - 1;
	42	}
	43	#---------------------------------------------------------
	44
	45	# number of tests in section 1
	46	my $bas_tests = 20;
	47
	48	# number of tests in section 3
	49	my $hmb_tests = 36;
	50
	51	printf "1..%d\n", $bas_tests + $num_tests + $hmb_tests;
a687059c	52
da405c16	53	my $CAT = ($^O eq 'MSWin32' \|\| $^O eq 'NetWare' \|\| $^O eq 'VMS') ? 'type'
2986a63f	54	: ($^O eq 'MacOS') ? 'catenate'
2986a63f	55	: 'cat';
3fe9a6f1	56
a1b95068	57	############
	58	## Section 1
	59	############
	60
a687059c	61	format OUT =
	62	the quick brown @<<
	63	$fox
	64	jumped
	65	@*
	66	$multiline
	67	^<<<<<<<<<
	68	$foo
	69	^<<<<<<<<<
	70	$foo
	71	^<<<<<<...
	72	$foo
	73	now @<<the@>>>> for all@\|\|\|\|\|men to come @<<<<
a0d0e21e	74	{
	75	'i' . 's', "time\n", $good, 'to'
	76	}
a687059c	77	.
a687059c	78
a0d0e21e	79	open(OUT, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
19f4d710	80	END { 1 while unlink 'Op_write.tmp' }
a687059c	81
	82	$fox = 'foxiness';
	83	$good = 'good';
	84	$multiline = "forescore\nand\nseven years\n";
	85	$foo = 'when in the course of human events it becomes necessary';
	86	write(OUT);
d1e4d418	87	close OUT or die "Could not close: $!";
a687059c	88
	89	$right =
	90	"the quick brown fox
	91	jumped
	92	forescore
	93	and
	94	seven years
	95	when in
	96	the course
	97	of huma...
	98	now is the time for all good men to come to\n";
	99
3fe9a6f1	100	if (`$CAT Op_write.tmp` eq $right)
784707d5	101	{ print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
a687059c	102	else
	103	{ print "not ok 1\n"; }
	104
748a9306	105	$fox = 'wolfishness';
	106	my $fox = 'foxiness'; # Test a lexical variable.
	107
a687059c	108	format OUT2 =
	109	the quick brown @<<
	110	$fox
	111	jumped
	112	@*
	113	$multiline
	114	^<<<<<<<<< ~~
	115	$foo
	116	now @<<the@>>>> for all@\|\|\|\|\|men to come @<<<<
	117	'i' . 's', "time\n", $good, 'to'
	118	.
	119
a0d0e21e	120	open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
a687059c	121
a687059c	122	$good = 'good';
	123	$multiline = "forescore\nand\nseven years\n";
	124	$foo = 'when in the course of human events it becomes necessary';
	125	write(OUT2);
d1e4d418	126	close OUT2 or die "Could not close: $!";
a687059c	127
	128	$right =
	129	"the quick brown fox
	130	jumped
	131	forescore
	132	and
	133	seven years
	134	when in
	135	the course
	136	of human
	137	events it
	138	becomes
	139	necessary
	140	now is the time for all good men to come to\n";
	141
3fe9a6f1	142	if (`$CAT Op_write.tmp` eq $right)
784707d5	143	{ print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
a687059c	144	else
	145	{ print "not ok 2\n"; }
	146
0f85fab0	147	eval <<'EOFORMAT';
	148	format OUT2 =
	149	the brown quick @<<
	150	$fox
	151	jumped
	152	@*
	153	$multiline
a0d0e21e	154	and
0f85fab0	155	^<<<<<<<<< ~~
	156	$foo
	157	now @<<the@>>>> for all@\|\|\|\|\|men to come @<<<<
	158	'i' . 's', "time\n", $good, 'to'
	159	.
	160	EOFORMAT
	161
a0d0e21e	162	open(OUT2, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
0f85fab0	163
	164	$fox = 'foxiness';
	165	$good = 'good';
	166	$multiline = "forescore\nand\nseven years\n";
	167	$foo = 'when in the course of human events it becomes necessary';
	168	write(OUT2);
d1e4d418	169	close OUT2 or die "Could not close: $!";
0f85fab0	170
	171	$right =
	172	"the brown quick fox
	173	jumped
	174	forescore
	175	and
	176	seven years
a0d0e21e	177	and
0f85fab0	178	when in
	179	the course
	180	of human
	181	events it
	182	becomes
	183	necessary
	184	now is the time for all good men to come to\n";
	185
3fe9a6f1	186	if (`$CAT Op_write.tmp` eq $right)
784707d5	187	{ print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
0f85fab0	188	else
	189	{ print "not ok 3\n"; }
	190
55497cff	191	# formline tests
	192
	193	$mustbe = <<EOT;
	194	@ a
	195	@> ab
	196	@>> abc
	197	@>>> abc
	198	@>>>> abc
	199	@>>>>> abc
	200	@>>>>>> abc
	201	@>>>>>>> abc
	202	@>>>>>>>> abc
	203	@>>>>>>>>> abc
	204	@>>>>>>>>>> abc
	205	EOT
	206
	207	$was1 = $was2 = '';
	208	for (0..10) {
	209	# lexical picture
	210	$^A = '';
	211	my $format1 = '@' . '>' x $_;
	212	formline $format1, 'abc';
	213	$was1 .= "$format1 $^A\n";
	214	# global
	215	$^A = '';
	216	local $format2 = '@' . '>' x $_;
	217	formline $format2, 'abc';
	218	$was2 .= "$format2 $^A\n";
	219	}
	220	print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
	221	print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";
	222
7056ecde	223	$^A = '';
	224
	225	# more test
	226
	227	format OUT3 =
	228	^<<<<<<...
	229	$foo
	230	.
	231
	232	open(OUT3, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	233
	234	$foo = 'fit ';
	235	write(OUT3);
d1e4d418	236	close OUT3 or die "Could not close: $!";
7056ecde	237
	238	$right =
	239	"fit\n";
	240
	241	if (`$CAT Op_write.tmp` eq $right)
784707d5	242	{ print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
7056ecde	243	else
	244	{ print "not ok 6\n"; }
	245
445b3f51	246	# test lexicals and globals
	247	{
	248	my $this = "ok";
	249	our $that = 7;
	250	format LEX =
	251	@<<@\|
	252	$this,$that
	253	.
	254	open(LEX, ">&STDOUT") or die;
	255	write LEX;
	256	$that = 8;
	257	write LEX;
d1e4d418	258	close LEX or die "Could not close: $!";
445b3f51	259	}
c2e66d9e	260	# LEX_INTERPNORMAL test
	261	my %e = ( a => 1 );
	262	format OUT4 =
	263	@<<<<<<
	264	"$e{a}"
	265	.
	266	open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
	267	write (OUT4);
d1e4d418	268	close OUT4 or die "Could not close: $!";
c2e66d9e	269	if (`$CAT Op_write.tmp` eq "1\n") {
c2e66d9e	270	print "ok 9\n";
784707d5	271	1 while unlink "Op_write.tmp";
c2e66d9e	272	}
	273	else {
	274	print "not ok 9\n";
	275	}
784707d5	276
	277	eval <<'EOFORMAT';
	278	format OUT10 =
	279	@####.## @0###.##
	280	$test1, $test1
	281	.
	282	EOFORMAT
	283
	284	open(OUT10, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	285
	286	$test1 = 12.95;
	287	write(OUT10);
d1e4d418	288	close OUT10 or die "Could not close: $!";
784707d5	289
	290	$right = " 12.95 00012.95\n";
	291	if (`$CAT Op_write.tmp` eq $right)
	292	{ print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
	293	else
	294	{ print "not ok 10\n"; }
	295
	296	eval <<'EOFORMAT';
	297	format OUT11 =
	298	@0###.##
	299	$test1
	300	@ 0#
	301	$test1
	302	@0 #
	303	$test1
	304	.
	305	EOFORMAT
	306
	307	open(OUT11, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	308
	309	$test1 = 12.95;
	310	write(OUT11);
d1e4d418	311	close OUT11 or die "Could not close: $!";
784707d5	312
	313	$right =
	314	"00012.95
	315	1 0#
	316	10 #\n";
	317	if (`$CAT Op_write.tmp` eq $right)
	318	{ print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
	319	else
	320	{ print "not ok 11\n"; }
9ccde9ea	321
31869a79	322	{
71f882da	323	my $el;
a1b95068	324	format OUT12 =
31869a79	325	ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
	326	$el
	327	.
	328	my %hash = (12 => 3);
a1b95068	329	open(OUT12, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
a1b95068	330
31869a79	331	for $el (keys %hash) {
a1b95068	332	write(OUT12);
31869a79	333	}
a1b95068	334	close OUT12 or die "Could not close: $!";
	335	print `$CAT Op_write.tmp`;
	336
31869a79	337	}
31869a79	338
ea42cebc	339	{
	340	# Bug report and testcase by Alexey Tourbin
	341	use Tie::Scalar;
	342	my $v;
	343	tie $v, 'Tie::StdScalar';
	344	$v = 13;
	345	format OUT13 =
	346	ok ^<<<<<<<<< ~~
	347	$v
	348	.
	349	open(OUT13, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	350	write(OUT13);
	351	close OUT13 or die "Could not close: $!";
	352	print `$CAT Op_write.tmp`;
	353	}
	354
a1b95068	355	{ # test 14
	356	# Bug #24774 format without trailing \n failed assertion, but this
	357	# must fail since we have a trailing ; in the eval'ed string (WL)
f5c235e7	358	my @v = ('k');
f5c235e7	359	eval "format OUT14 = \n@\n\@v";
c5ee2135	360	print $@ ? "ok 14\n" : "not ok 14\n";
c5ee2135	361
f5c235e7	362	}
f5c235e7	363
a1b95068	364	{ # test 15
	365	# text lost in ^<<< field with \r in value (WL)
	366	my $txt = "line 1\rline 2";
	367	format OUT15 =
	368	^<<<<<<<<<<<<<<<<<<
	369	$txt
	370	^<<<<<<<<<<<<<<<<<<
	371	$txt
	372	.
	373	open(OUT15, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	374	write(OUT15);
	375	close OUT15 or die "Could not close: $!";
	376	my $res = `$CAT Op_write.tmp`;
	377	print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n";
	378	}
	379
	380	{ # test 16: multiple use of a variable in same line with ^<
	381	my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
	382	format OUT16 =
	383	^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
	384	$txt, $txt
	385	^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
	386	$txt, $txt
	387	.
	388	open(OUT16, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	389	write(OUT16);
	390	close OUT16 or die "Could not close: $!";
	391	my $res = `$CAT Op_write.tmp`;
	392	print $res eq <<EOD ? "ok 16\n" : "not ok 16\n";
	393	this_is_block_1 this_is_block_2
	394	this_is_block_3 this_is_block_4
	395	EOD
	396	}
	397
	398	{ # test 17: @* "should be on a line of its own", but it should work
	399	# cleanly with literals before and after. (WL)
	400
	401	my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
	402	format OUT17 =
	403	Here we go: @* That's all, folks!
	404	$txt
	405	.
	406	open(OUT17, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	407	write(OUT17);
	408	close OUT17 or die "Could not close: $!";
	409	my $res = `$CAT Op_write.tmp`;
	410	chomp( $txt );
	411	my $exp = <<EOD;
	412	Here we go: $txt That's all, folks!
	413	EOD
	414	print $res eq $exp ? "ok 17\n" : "not ok 17\n";
	415	}
	416
	417	{ # test 18: @# and ~~ would cause runaway format, but we now
	418	# catch this while compiling (WL)
	419
	420	format OUT18 =
	421	@######## ~~
	422	10
	423	.
	424	open(OUT18, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	425	eval { write(OUT18); };
	426	print $@ ? "ok 18\n" : "not ok 18\n";
	427	close OUT18 or die "Could not close: $!";
428	}
429
430	{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
431	my $v = 'gaga';
432	eval "format OUT19 = \n" .
433	'@<<<' . "\0\n" .
434	'$v' . "\n" .
435	'@<<<' . "\0\n" .
436	'$v' . "\n.\n";
437	open(OUT19, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
438	write(OUT19);
439	my $res = `$CAT Op_write.tmp`;
440	print $res eq <<EOD ? "ok 19\n" : "not ok 19\n";
441	gaga\0
442	gaga\0
443	EOD
444	}
445
446	{ # test 20: hash accesses; single '}' must not terminate format '}' (WL)
447	my %h = ( xkey => 'xval', ykey => 'yval' );
448	format OUT20 =
449	@>>>> @<<<< ~~
450	each %h
451	@>>>> @<<<<
452	$h{xkey}, $h{ykey}
453	@>>>> @<<<<
454	{ $h{xkey}, $h{ykey}
455	}
456	}
457	.
458	my $exp = '';
459	while( my( $k, $v ) = each( %h ) ){
460	$exp .= sprintf( "%5s %s\n", $k, $v );
461	}
462	$exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
463	$exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
464	$exp .= "}\n";
465	open(OUT20, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
466	write(OUT20);
467	my $res = `$CAT Op_write.tmp`;
468	print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n";
469
470	EOD
471	}
472
473
474	#####################
475	## Section 2
476	## numeric formatting
477	#####################
478
479	my $nt = $bas_tests;
480	for my $tref ( @NumTests ){
481	my $writefmt = shift( @$tref );
482	my $printfmt = mkfmt( $writefmt );
483	my $blank_when_undef = substr( $writefmt, 0, 1 ) eq '^';
484	for my $val ( @$tref ){
485	my $writeres = swrite( $writefmt, $val );
486	my $printres;
487	if( $blank_when_undef && ! defined($val) ){
488	$printres = ' ' x length( $writefmt );
489	} else {
490	$printres = sprintf( $printfmt, $val \|\| 0 );
491	if( length($printres) > length( $writefmt ) ){
492	$printres = '#' x length( $writefmt );
493	}
494	}
495	$nt++;
496
497	print $printres eq $writeres ? "ok $nt\n" : "not ok $nt\n";
498	}
499	}
500
501
502	#####################################
503	## Section 3
504	## Easiest to add new tests above here
ea42cebc	505	#######################################
ea42cebc	506
a1b95068	507	# scary format testing from H.Merijn Brand
ea42cebc	508
a1b95068	509	my $test = $bas_tests + $num_tests + 1;
a1b95068	510	my $tests = $bas_tests + $num_tests + $hmb_tests;
9ccde9ea	511
dc459aad	512	if ($^O eq 'VMS' \|\| $^O eq 'MSWin32' \|\| $^O eq 'dos' \|\| $^O eq 'MacOS' \|\|
764df951	513	($^O eq 'os2' and not eval '$OS2::can_fork')) {
ea42cebc	514	foreach ($test..$tests) {
	515	print "ok $_ # skipped: '\|-' and '-\|' not supported\n";
	516	}
d4a0c6f3	517	exit(0);
	518	}
	519
9ccde9ea	520
ea42cebc	521	use strict; # Amazed that this hackery can be made strict ...
d57f9278	522
9ccde9ea	523	# Just a complete test for format, including top-, left- and bottom marging
	524	# and format detection through glob entries
	525
d57f9278	526	format EMPTY =
	527	.
	528
	529	format Comment =
	530	ok @<<<<<
	531	$test
	532	.
	533
d57f9278	534
d57f9278	535	# [ID 20020227.005] format bug with undefined _TOP
0bd0581c	536
	537	open STDOUT_DUP, ">&STDOUT";
	538	my $oldfh = select STDOUT_DUP;
	539	$= = 10;
d57f9278	540	{ local $~ = "Comment";
	541	write;
	542	$test++;
	543	print $- == 9
3444c34c	544	? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
d57f9278	545	$test++;
0bd0581c	546	print $^ eq "STDOUT_DUP_TOP"
0bd0581c	547	? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
d57f9278	548	$test++;
0bd0581c	549	}
0bd0581c	550	select $oldfh;
d57f9278	551
0bd0581c	552	$^ = "STDOUT_TOP";
	553	$= = 7; # Page length
	554	$- = 0; # Lines left
9ccde9ea	555	my $ps = $^L; $^L = ""; # Catch the page separator
	556	my $tm = 1; # Top margin (empty lines before first output)
	557	my $bm = 2; # Bottom marging (empty lines between last text and footer)
	558	my $lm = 4; # Left margin (indent in spaces)
	559
362819fd	560	select ((select (STDOUT), $\| = 1)[0]);
9ccde9ea	561	if ($lm > 0 and !open STDOUT, "\|-") { # Left margin (in this test ALWAYS set)
362819fd	562	select ((select (STDOUT), $\| = 1)[0]);
9ccde9ea	563	my $s = " " x $lm;
	564	while (<STDIN>) {
	565	s/^/$s/;
d57f9278	566	print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
9ccde9ea	567	}
9ccde9ea	568	close STDIN;
d57f9278	569	print + (<DATA>?"not ":""), "ok ", $test++, "\n";
9ccde9ea	570	close STDOUT;
	571	exit;
	572	}
	573	$tm = "\n" x $tm;
	574	$= -= $bm + 1; # count one for the trailing "----"
	575	my $lastmin = 0;
	576
	577	my @E;
	578
	579	sub wryte
	580	{
	581	$lastmin = $-;
	582	write;
	583	} # wryte;
	584
	585	sub footer
	586	{
	587	$% == 1 and return "";
	588
	589	$lastmin < $= and print "\n" x $lastmin;
	590	print "\n" x $bm, "----\n", $ps;
	591	$lastmin = $-;
	592	"";
	593	} # footer
	594
	595	# Yes, this is sick ;-)
	596	format TOP =
	597	@* ~
	598	@{[footer]}
	599	@* ~
	600	$tm
	601	.
	602
9ccde9ea	603	format ENTRY =
	604	@ @<<<<~~
	605	@{(shift @E)\|\|["",""]}
	606	.
	607
	608	format EOR =
	609	- -----
	610	.
	611
	612	sub has_format ($)
	613	{
	614	my $fmt = shift;
	615	exists $::{$fmt} or return 0;
	616	$^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
	617	open my $null, "> /dev/null" or die;
	618	my $fh = select $null;
	619	local $~ = $fmt;
	620	eval "write";
	621	select $fh;
	622	$@?0:1;
	623	} # has_format
	624
d57f9278	625	$^ = has_format ("TOP") ? "TOP" : "EMPTY";
9ccde9ea	626	has_format ("ENTRY") or die "No format defined for ENTRY";
	627	foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
	628	[ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
	629	@E = @$e;
	630	local $~ = "ENTRY";
	631	wryte;
	632	has_format ("EOR") or next;
	633	local $~ = "EOR";
	634	wryte;
	635	}
	636	if (has_format ("EOF")) {
	637	local $~ = "EOF";
	638	wryte;
	639	}
	640
	641	close STDOUT;
	642
ea42cebc	643	# That was test 48.
9ccde9ea	644
	645	__END__
	646
	647	1 Test1
	648	2 Test2
	649	3 Test3
	650
	651
	652	----
	653	\f
	654	4 Test4
	655	5 Test5
	656	6 Test6
	657
	658
	659	----
	660	\f
	661	7 Test7
	662	- -----
	663
	664
	665
	666	----
	667	\f
	668	1 1tseT
	669	2 2tseT
	670	3 3tseT
	671
	672
	673	----
	674	\f
	675	4 4tseT
	676	5 5tseT
	677	- -----