[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 = 37;

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 $@ ? "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);
    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 ...

# 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 litle 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
68ba3c2c	61	my $hmb_tests = 37;
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";
c5ee2135	368	print $@ ? "ok 14\n" : "not ok 14\n";
c5ee2135	369
f5c235e7	370	}
f5c235e7	371
a1b95068	372	{ # test 15
	373	# text lost in ^<<< field with \r in value (WL)
	374	my $txt = "line 1\rline 2";
	375	format OUT15 =
	376	^<<<<<<<<<<<<<<<<<<
	377	$txt
	378	^<<<<<<<<<<<<<<<<<<
	379	$txt
	380	.
	381	open(OUT15, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	382	write(OUT15);
	383	close OUT15 or die "Could not close: $!";
a344b90b	384	my $res = cat('Op_write.tmp');
a1b95068	385	print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n";
	386	}
	387
	388	{ # test 16: multiple use of a variable in same line with ^<
	389	my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
	390	format OUT16 =
	391	^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
	392	$txt, $txt
	393	^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
	394	$txt, $txt
	395	.
	396	open(OUT16, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	397	write(OUT16);
	398	close OUT16 or die "Could not close: $!";
a344b90b	399	my $res = cat('Op_write.tmp');
a1b95068	400	print $res eq <<EOD ? "ok 16\n" : "not ok 16\n";
	401	this_is_block_1 this_is_block_2
	402	this_is_block_3 this_is_block_4
	403	EOD
	404	}
	405
	406	{ # test 17: @* "should be on a line of its own", but it should work
	407	# cleanly with literals before and after. (WL)
	408
	409	my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
	410	format OUT17 =
	411	Here we go: @* That's all, folks!
	412	$txt
	413	.
	414	open(OUT17, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	415	write(OUT17);
	416	close OUT17 or die "Could not close: $!";
a344b90b	417	my $res = cat('Op_write.tmp');
a1b95068	418	chomp( $txt );
	419	my $exp = <<EOD;
	420	Here we go: $txt That's all, folks!
	421	EOD
	422	print $res eq $exp ? "ok 17\n" : "not ok 17\n";
	423	}
	424
	425	{ # test 18: @# and ~~ would cause runaway format, but we now
	426	# catch this while compiling (WL)
	427
	428	format OUT18 =
	429	@######## ~~
	430	10
	431	.
	432	open(OUT18, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	433	eval { write(OUT18); };
	434	print $@ ? "ok 18\n" : "not ok 18\n";
	435	close OUT18 or die "Could not close: $!";
	436	}
	437
	438	{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
	439	my $v = 'gaga';
	440	eval "format OUT19 = \n" .
	441	'@<<<' . "\0\n" .
	442	'$v' . "\n" .
	443	'@<<<' . "\0\n" .
	444	'$v' . "\n.\n";
	445	open(OUT19, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	446	write(OUT19);
a344b90b	447	close OUT19 or die "Could not close: $!";
a344b90b	448	my $res = cat('Op_write.tmp');
a1b95068	449	print $res eq <<EOD ? "ok 19\n" : "not ok 19\n";
	450	gaga\0
	451	gaga\0
	452	EOD
	453	}
	454
	455	{ # test 20: hash accesses; single '}' must not terminate format '}' (WL)
	456	my %h = ( xkey => 'xval', ykey => 'yval' );
	457	format OUT20 =
	458	@>>>> @<<<< ~~
	459	each %h
	460	@>>>> @<<<<
	461	$h{xkey}, $h{ykey}
	462	@>>>> @<<<<
	463	{ $h{xkey}, $h{ykey}
	464	}
	465	}
	466	.
	467	my $exp = '';
	468	while( my( $k, $v ) = each( %h ) ){
	469	$exp .= sprintf( "%5s %s\n", $k, $v );
	470	}
	471	$exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
	472	$exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
	473	$exp .= "}\n";
	474	open(OUT20, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
	475	write(OUT20);
a344b90b	476	close OUT20 or die "Could not close: $!";
a344b90b	477	my $res = cat('Op_write.tmp');
a1b95068	478	print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n";
a1b95068	479	}
	480
	481
	482	#####################
	483	## Section 2
	484	## numeric formatting
	485	#####################
	486
	487	my $nt = $bas_tests;
	488	for my $tref ( @NumTests ){
	489	my $writefmt = shift( @$tref );
d1f6232e	490	while (@$tref) {
	491	my $val = shift @$tref;
	492	my $expected = shift @$tref;
a1b95068	493	my $writeres = swrite( $writefmt, $val );
a1b95068	494	$nt++;
8975a8c2	495	my $ok = ref($expected)
	496	? $writeres =~ $expected
	497	: $writeres eq $expected;
	498
	499	print $ok
68ba3c2c	500	? "ok $nt - $writefmt\n"
176ab42a	501	: "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n";
a1b95068	502	}
	503	}
	504
	505
	506	#####################################
	507	## Section 3
	508	## Easiest to add new tests above here
ea42cebc	509	#######################################
ea42cebc	510
a1b95068	511	# scary format testing from H.Merijn Brand
ea42cebc	512
a1b95068	513	my $test = $bas_tests + $num_tests + 1;
a1b95068	514	my $tests = $bas_tests + $num_tests + $hmb_tests;
9ccde9ea	515
dc459aad	516	if ($^O eq 'VMS' \|\| $^O eq 'MSWin32' \|\| $^O eq 'dos' \|\| $^O eq 'MacOS' \|\|
764df951	517	($^O eq 'os2' and not eval '$OS2::can_fork')) {
ea42cebc	518	foreach ($test..$tests) {
	519	print "ok $_ # skipped: '\|-' and '-\|' not supported\n";
	520	}
d4a0c6f3	521	exit(0);
	522	}
	523
9ccde9ea	524
ea42cebc	525	use strict; # Amazed that this hackery can be made strict ...
d57f9278	526
9ccde9ea	527	# Just a complete test for format, including top-, left- and bottom marging
	528	# and format detection through glob entries
	529
d57f9278	530	format EMPTY =
	531	.
	532
	533	format Comment =
	534	ok @<<<<<
	535	$test
	536	.
	537
d57f9278	538
d57f9278	539	# [ID 20020227.005] format bug with undefined _TOP
0bd0581c	540
	541	open STDOUT_DUP, ">&STDOUT";
	542	my $oldfh = select STDOUT_DUP;
	543	$= = 10;
d57f9278	544	{ local $~ = "Comment";
	545	write;
	546	$test++;
	547	print $- == 9
3444c34c	548	? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
d57f9278	549	$test++;
0bd0581c	550	print $^ eq "STDOUT_DUP_TOP"
0bd0581c	551	? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
d57f9278	552	$test++;
0bd0581c	553	}
0bd0581c	554	select $oldfh;
68ba3c2c	555	close STDOUT_DUP;
d57f9278	556
0bd0581c	557	$^ = "STDOUT_TOP";
	558	$= = 7; # Page length
	559	$- = 0; # Lines left
9ccde9ea	560	my $ps = $^L; $^L = ""; # Catch the page separator
	561	my $tm = 1; # Top margin (empty lines before first output)
	562	my $bm = 2; # Bottom marging (empty lines between last text and footer)
	563	my $lm = 4; # Left margin (indent in spaces)
	564
68ba3c2c	565	# -----------------------------------------------------------------------
	566	#
	567	# execute the rest of the script in a child process. The parent reads the
	568	# output from the child and compares it with <DATA>.
	569
	570	my @data = <DATA>;
	571
	572	select ((select (STDOUT), $\| = 1)[0]); # flush STDOUT
	573
	574	my $opened = open FROM_CHILD, "-\|";
	575	unless (defined $opened) {
	576	print "not ok $test - open gave $!\n"; exit 0;
	577	}
	578
	579	if ($opened) {
	580	# in parent here
	581
	582	print "ok $test - open\n"; $test++;
9ccde9ea	583	my $s = " " x $lm;
68ba3c2c	584	while (<FROM_CHILD>) {
	585	unless (@data) {
	586	print "not ok $test - too much output\n";
	587	exit;
	588	}
9ccde9ea	589	s/^/$s/;
68ba3c2c	590	my $exp = shift @data;
	591	print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n";
	592	if ($_ ne $exp) {
	593	s/\n/\\n/g for $_, $exp;
	594	print "#expected: $exp\n#got: $_\n";
9ccde9ea	595	}
9ccde9ea	596	}
68ba3c2c	597	close FROM_CHILD;
	598	print + (@data?"not ":""), "ok ", $test++, " - too litle output\n";
	599	exit;
	600	}
	601
	602	# in child here
	603
	604	select ((select (STDOUT), $\| = 1)[0]);
9ccde9ea	605	$tm = "\n" x $tm;
	606	$= -= $bm + 1; # count one for the trailing "----"
	607	my $lastmin = 0;
	608
	609	my @E;
	610
	611	sub wryte
	612	{
	613	$lastmin = $-;
	614	write;
	615	} # wryte;
	616
	617	sub footer
	618	{
	619	$% == 1 and return "";
	620
	621	$lastmin < $= and print "\n" x $lastmin;
	622	print "\n" x $bm, "----\n", $ps;
	623	$lastmin = $-;
	624	"";
	625	} # footer
	626
	627	# Yes, this is sick ;-)
	628	format TOP =
	629	@* ~
	630	@{[footer]}
	631	@* ~
	632	$tm
	633	.
	634
9ccde9ea	635	format ENTRY =
	636	@ @<<<<~~
	637	@{(shift @E)\|\|["",""]}
	638	.
	639
	640	format EOR =
	641	- -----
	642	.
	643
	644	sub has_format ($)
	645	{
	646	my $fmt = shift;
	647	exists $::{$fmt} or return 0;
	648	$^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
	649	open my $null, "> /dev/null" or die;
	650	my $fh = select $null;
	651	local $~ = $fmt;
	652	eval "write";
	653	select $fh;
	654	$@?0:1;
	655	} # has_format
	656
d57f9278	657	$^ = has_format ("TOP") ? "TOP" : "EMPTY";
9ccde9ea	658	has_format ("ENTRY") or die "No format defined for ENTRY";
	659	foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
	660	[ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
	661	@E = @$e;
	662	local $~ = "ENTRY";
	663	wryte;
	664	has_format ("EOR") or next;
	665	local $~ = "EOR";
	666	wryte;
	667	}
	668	if (has_format ("EOF")) {
	669	local $~ = "EOF";
	670	wryte;
	671	}
	672
	673	close STDOUT;
	674
ea42cebc	675	# That was test 48.
9ccde9ea	676
	677	__END__
	678
	679	1 Test1
	680	2 Test2
	681	3 Test3
	682
	683
	684	----
	685	\f
	686	4 Test4
	687	5 Test5
	688	6 Test6
	689
	690
	691	----
	692	\f
	693	7 Test7
	694	- -----
	695
	696
	697
	698	----
	699	\f
	700	1 1tseT
	701	2 2tseT
	702	3 3tseT
	703
	704
	705	----
	706	\f
	707	4 4tseT
	708	5 5tseT
	709	- -----