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

#!./perl

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

# read in a file
sub cat {
    my $file = shift;
    local $/;
    open my $fh, $file or die "can't open '$file': $!";
    my $data = <$fh>;
    close $fh;
    $data;
}

#-- 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 = (
    # [ format, value1, expected1, value2, expected2, .... ]
    [ '@###',           0,   '   0',         1, '   1',     9999.6, '####',
		9999.4999,   '9999',    -999.6, '####',     1e+100, '####' ],

    [ '@0##',           0,   '0000',         1, '0001',     9999.6, '####',
		-999.4999,   '-999',    -999.6, '####',     1e+100, '####' ],

    [ '^###',           0,   '   0',     undef, '    ' ],

    [ '^0##',           0,   '0000',     undef, '    ' ],

    [ '@###.',          0,  '   0.',         1, '   1.',    9999.6, '#####',
                9999.4999,  '9999.',    -999.6, '#####' ],

    [ '@##.##',         0, '  0.00',         1, '  1.00',  999.996, '######',
                999.99499, '999.99',      -100, '######' ],

    [ '@0#.##',         0, '000.00',         1, '001.00',       10, '010.00',
                  -0.0001, qr/^[\-0]00\.00$/ ],

);


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

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

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

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

############
## 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 +($@ && $@ =~ /Format not terminated/)
      ? "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 +($@ && $@ =~ /Repeated format line will never terminate/)
      ? "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);
    close OUT19 or die "Could not close: $!";
    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);
    close OUT20 or die "Could not close: $!";
    my $res = cat('Op_write.tmp');
    print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n";
}


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

my $nt = $bas_tests;
for my $tref ( @NumTests ){
    my $writefmt = shift( @$tref );
    while (@$tref) {
	my $val      = shift @$tref;
	my $expected = shift @$tref;
        my $writeres = swrite( $writefmt, $val );
        $nt++;
	my $ok = ref($expected)
		 ? $writeres =~ $expected
		 : $writeres eq $expected;
	
        print $ok
	    ? "ok $nt - $writefmt\n"
	    : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\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 ...

# DAPM. Exercise a couple of error codepaths

{
    local $~ = '';
    eval { write };
    print "not " unless $@ and $@ =~ /Not a format reference/;
    print "ok $test - Not a format reference\n";
    $test++;

    $~ = "NOSUCHFORMAT";
    eval { write };
    print "not " unless $@ and $@ =~ /Undefined format/;
    print "ok $test - Undefined format\n";
    $test++;
}

# 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;
close STDOUT_DUP;

$^  = "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)

# -----------------------------------------------------------------------
#
# execute the rest of the script in a child process. The parent reads the
# output from the child and compares it with <DATA>.

my @data = <DATA>;

select ((select (STDOUT), $| = 1)[0]); # flush STDOUT

my $opened = open FROM_CHILD, "-|";
unless (defined $opened) {
    print "not ok $test - open gave $!\n"; exit 0;
}

if ($opened) {
    # in parent here

    print "ok $test - open\n"; $test++;
    my $s = " " x $lm;
    while (<FROM_CHILD>) {
	unless (@data) {
	    print "not ok $test - too much output\n";
	    exit;
	}
	s/^/$s/;
	my $exp = shift @data;
	print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n";
	if ($_ ne $exp) {
	    s/\n/\\n/g for $_, $exp;
	    print "#expected: $exp\n#got:      $_\n";
	}
    }
    close FROM_CHILD;
    print + (@data?"not ":""), "ok ", $test++, " - too little output\n";
    exit;
}

# in child here

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