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

#!./perl

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

# 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 $bug_tests = 4;

# number of tests in section 4
my $hmb_tests = 35;

my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests;

plan $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 just here
#######################################

curr_test($bas_tests + $num_tests + 1);

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

# DAPM. Exercise a couple of error codepaths

{
    local $~ = '';
    eval { write };
    like $@, qr/Not a format reference/, 'format reference';

    $~ = "NOSUCHFORMAT";
    eval { write };
    like $@, qr/Undefined format/, 'no such format';
}


format EMPTY =
.

my $test = curr_test();

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;
  curr_test($test + 1);
  {
    local $::TODO = '[ID 20020227.005] format bug with undefined _TOP';
    is $-, 9;
  }
  is $^, "STDOUT_DUP_TOP";
}
select $oldfh;
close STDOUT_DUP;

# scary format testing from H.Merijn Brand

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

if (1 || $^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
    ($^O eq 'os2' and not eval '$OS2::can_fork')) {
  $test = curr_test();
 SKIP: {
      skip "'|-' and '-|' not supported", $tests - $test + 1;
  }
  exit(0);
}


$^  = "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) {
    fail "open gave $!";
    exit 0;
}

if ($opened) {
    # in parent here

    pass 'open';
    my $s = " " x $lm;
    while (<FROM_CHILD>) {
	unless (@data) {
	    fail 'too much output';
	    exit;
	}
	s/^/$s/;
	my $exp = shift @data;
	is $_, $exp;
    }
    close FROM_CHILD;
    is "@data", "", "correct length of output";
    exit;
}

# in child here
$::NO_ENDING = 1;

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