[perl5.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 = 36;

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\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;

$^  = "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 LW	1	#!./perl
a687059c LW	2
9ccde9ea JH	3	BEGIN {
	4	chdir 't' if -d 't';
	5	@INC = '../lib';
	6	}
	7
a344b90b DM	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 LW	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 DM	29	[ '@###', 0, ' 0', 1, ' 1', 9999.6, '####',
9acd3e2c DM	30	9999.4999, '9999', -999.6, '####', 1e+100, '####' ],
d1f6232e	31
9acd3e2c DM	32	[ '@0##', 0, '0000', 1, '0001', 9999.6, '####',
9acd3e2c DM	33	-999.4999, '-999', -999.6, '####', 1e+100, '####' ],
d1f6232e DM	34
	35	[ '^###', 0, ' 0', undef, ' ' ],
	36
	37	[ '^0##', 0, '0000', undef, ' ' ],
	38
9acd3e2c DM	39	[ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####',
9acd3e2c DM	40	9999.4999, '9999.', -999.6, '#####' ],
d1f6232e	41
9acd3e2c	42	[ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######',
d1f6232e DM	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 DM	47
	48	);
	49
a1b95068 LW	50
	51	my $num_tests = 0;
	52	for my $tref ( @NumTests ){
d1f6232e	53	$num_tests += (@$tref - 1)/2;
a1b95068 LW	54	}
	55	#---------------------------------------------------------
	56
	57	# number of tests in section 1
	58	my $bas_tests = 20;
	59
	60	# number of tests in section 3
	61	my $hmb_tests = 36;
	62
	63	printf "1..%d\n", $bas_tests + $num_tests + $hmb_tests;
a687059c	64
a1b95068 LW	65	############
	66	## Section 1
	67	############
	68
a687059c LW	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 LW	82	{
	83	'i' . 's', "time\n", $good, 'to'
	84	}
a687059c LW	85	.
a687059c LW	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 LW	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 LW	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 LW	110	else
	111	{ print "not ok 1\n"; }
	112
748a9306 LW	113	$fox = 'wolfishness';
	114	my $fox = 'foxiness'; # Test a lexical variable.
	115
a687059c LW	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 LW	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 LW	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 LW	152	else
	153	{ print "not ok 2\n"; }
	154
0f85fab0 LW	155	eval <<'EOFORMAT';
	156	format OUT2 =
	157	the brown quick @<<
	158	$fox
	159	jumped
	160	@*
	161	$multiline
a0d0e21e	162	and
0f85fab0 LW	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 LW	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 LW	178
	179	$right =
	180	"the brown quick fox
	181	jumped
	182	forescore
	183	and
	184	seven years
a0d0e21e	185	and
0f85fab0 LW	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 LW	196	else
	197	{ print "not ok 3\n"; }
	198
55497cff PP	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 URCI	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 URCI	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 URCI	251	else
	252	{ print "not ok 6\n"; }
	253
445b3f51 GS	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 GS	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 GS	280	}
	281	else {
	282	print "not ok 9\n";
	283	}
784707d5 JP	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 JP	297
784707d5 JP	298	$right = " 12.95 00012.95\n";
a344b90b	299	if (cat('Op_write.tmp') eq $right)
784707d5 JP	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 JP	320
	321	$right =
	322	"00012.95
	323	1 0#
	324	10 #\n";
a344b90b	325	if (cat('Op_write.tmp') eq $right)
784707d5 JP	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 AE	333	ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
	334	$el
	335	.
	336	my %hash = (12 => 3);
a1b95068 LW	337	open(OUT12, '>Op_write.tmp') \|\| die "Can't create Op_write.tmp";
a1b95068 LW	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 AE	345	}
31869a79 AE	346
ea42cebc RGS	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 RGS	361	}
ea42cebc RGS	362
a1b95068 LW	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 DM	366	my @v = ('k');
f5c235e7 DM	367	eval "format OUT14 = \n@\n\@v";
c5ee2135 LW	368	print $@ ? "ok 14\n" : "not ok 14\n";
c5ee2135 LW	369
f5c235e7 DM	370	}
f5c235e7 DM	371
a1b95068 LW	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 LW	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 LW	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 LW	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 DM	447	close OUT19 or die "Could not close: $!";
a344b90b DM	448	my $res = cat('Op_write.tmp');
a1b95068 LW	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 DM	476	close OUT20 or die "Could not close: $!";
a344b90b DM	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 LW	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 DM	490	while (@$tref) {
	491	my $val = shift @$tref;
	492	my $expected = shift @$tref;
a1b95068	493	my $writeres = swrite( $writefmt, $val );
a1b95068	494	$nt++;
8975a8c2 DM	495	my $ok = ref($expected)
	496	? $writeres =~ $expected
	497	: $writeres eq $expected;
	498
	499	print $ok
176ab42a DM	500	? "ok $nt\n"
176ab42a DM	501	: "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n";
a1b95068 LW	502	}
	503	}
	504
	505
	506	#####################################
	507	## Section 3
	508	## Easiest to add new tests above here
ea42cebc RGS	509	#######################################
ea42cebc RGS	510
a1b95068	511	# scary format testing from H.Merijn Brand
ea42cebc	512
a1b95068 LW	513	my $test = $bas_tests + $num_tests + 1;
a1b95068 LW	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 RGS	518	foreach ($test..$tests) {
	519	print "ok $_ # skipped: '\|-' and '-\|' not supported\n";
	520	}
d4a0c6f3 CB	521	exit(0);
	522	}
	523
9ccde9ea	524
ea42cebc	525	use strict; # Amazed that this hackery can be made strict ...
d57f9278	526
9ccde9ea JH	527	# Just a complete test for format, including top-, left- and bottom marging
	528	# and format detection through glob entries
	529
d57f9278 MB	530	format EMPTY =
	531	.
	532
	533	format Comment =
	534	ok @<<<<<
	535	$test
	536	.
	537
d57f9278 MB	538
d57f9278 MB	539	# [ID 20020227.005] format bug with undefined _TOP
0bd0581c DM	540
	541	open STDOUT_DUP, ">&STDOUT";
	542	my $oldfh = select STDOUT_DUP;
	543	$= = 10;
d57f9278 MB	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 DM	550	print $^ eq "STDOUT_DUP_TOP"
0bd0581c DM	551	? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
d57f9278	552	$test++;
0bd0581c DM	553	}
0bd0581c DM	554	select $oldfh;
d57f9278	555
0bd0581c DM	556	$^ = "STDOUT_TOP";
	557	$= = 7; # Page length
	558	$- = 0; # Lines left
9ccde9ea JH	559	my $ps = $^L; $^L = ""; # Catch the page separator
	560	my $tm = 1; # Top margin (empty lines before first output)
	561	my $bm = 2; # Bottom marging (empty lines between last text and footer)
	562	my $lm = 4; # Left margin (indent in spaces)
	563
362819fd	564	select ((select (STDOUT), $\| = 1)[0]);
9ccde9ea	565	if ($lm > 0 and !open STDOUT, "\|-") { # Left margin (in this test ALWAYS set)
362819fd	566	select ((select (STDOUT), $\| = 1)[0]);
9ccde9ea JH	567	my $s = " " x $lm;
	568	while (<STDIN>) {
	569	s/^/$s/;
d57f9278	570	print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
9ccde9ea JH	571	}
9ccde9ea JH	572	close STDIN;
d57f9278	573	print + (<DATA>?"not ":""), "ok ", $test++, "\n";
9ccde9ea JH	574	close STDOUT;
	575	exit;
	576	}
	577	$tm = "\n" x $tm;
	578	$= -= $bm + 1; # count one for the trailing "----"
	579	my $lastmin = 0;
	580
	581	my @E;
	582
	583	sub wryte
	584	{
	585	$lastmin = $-;
	586	write;
	587	} # wryte;
	588
	589	sub footer
	590	{
	591	$% == 1 and return "";
	592
	593	$lastmin < $= and print "\n" x $lastmin;
	594	print "\n" x $bm, "----\n", $ps;
	595	$lastmin = $-;
	596	"";
	597	} # footer
	598
	599	# Yes, this is sick ;-)
	600	format TOP =
	601	@* ~
	602	@{[footer]}
	603	@* ~
	604	$tm
	605	.
	606
9ccde9ea JH	607	format ENTRY =
	608	@ @<<<<~~
	609	@{(shift @E)\|\|["",""]}
	610	.
	611
	612	format EOR =
	613	- -----
	614	.
	615
	616	sub has_format ($)
	617	{
	618	my $fmt = shift;
	619	exists $::{$fmt} or return 0;
	620	$^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
	621	open my $null, "> /dev/null" or die;
	622	my $fh = select $null;
	623	local $~ = $fmt;
	624	eval "write";
	625	select $fh;
	626	$@?0:1;
	627	} # has_format
	628
d57f9278	629	$^ = has_format ("TOP") ? "TOP" : "EMPTY";
9ccde9ea JH	630	has_format ("ENTRY") or die "No format defined for ENTRY";
	631	foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
	632	[ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
	633	@E = @$e;
	634	local $~ = "ENTRY";
	635	wryte;
	636	has_format ("EOR") or next;
	637	local $~ = "EOR";
	638	wryte;
	639	}
	640	if (has_format ("EOF")) {
	641	local $~ = "EOF";
	642	wryte;
	643	}
	644
	645	close STDOUT;
	646
ea42cebc	647	# That was test 48.
9ccde9ea JH	648
	649	__END__
	650
	651	1 Test1
	652	2 Test2
	653	3 Test3
	654
	655
	656	----
	657	\f
	658	4 Test4
	659	5 Test5
	660	6 Test6
	661
	662
	663	----
	664	\f
	665	7 Test7
	666	- -----
	667
	668
	669
	670	----
	671	\f
	672	1 1tseT
	673	2 2tseT
	674	3 3tseT
	675
	676
	677	----
	678	\f
	679	4 4tseT
	680	5 5tseT
	681	- -----