tags/v1_29/t/net/perl/io/perlio.pl

#!/user/local/bin/perl

use Config;

#we're in Apache::Registry
#our perl is configured use sfio so we can 
#print() to STDOUT
#and
#read() from STDIN

#we've also set (per-directory config):
#PerlSendHeader On
#PerlSetupEnv   On

my $r = shift;
my $sub = "test_$ENV{QUERY_STRING}";
if (defined &{$sub}) {
    &{$sub}($r);
}
else {
    print "Status: 200 Bottles of beer on the wall\n",
    "X-Perl-Version: $]\n";
    print "X-Perl-Script: perlio.pl\n";
    print "X-Message: hello\n";
    print "Content-type: text/plain\n\n";

    print "perlio test...\n";
    print "\$^X is $^X\n" if $^X;

    if($] >= 5.005 && $Config{usesfio} ne "true") {
	my $msg = "1234WRITEmethod";
	syswrite STDOUT, $msg, 5, 4;
	print " to STDOUT works with $] without sfio\n";
    }

    my $loc = $r->location;
    print "<Location $loc>\n";
    my(@args);

    if (@args = split(/\+/, $ENV{QUERY_STRING})) {
	print "ARGS: ",
	join(", ", map { $_ = qq{"$_"} } @args), "\n\n";
    } else {
	print "No command line arguments passed to script\n\n";
    }

    my($key,$val);
    while (($key,$val) = each %ENV) {
	print "$key=$val\n";
    }


    if ($ENV{CONTENT_LENGTH}) {
	$len = $ENV{CONTENT_LENGTH};
	read(STDIN, $content, $len);
	print "\nContent\n-------\n$content";
    }
}

sub test_1 {
    print "Content-type: text/html\n",
          "X-sub: " . "test_1\n";
    print "\r\n";
    print "1";
}

sub test_2 {
    my $msg = <<"EOF";
X-sub: test_2 
Content-type: text/html

2
EOF
    chomp $msg;
    print $msg;
}

sub test_3 {
    my $h = {
	"Content-type" => "text/plain",
	"X-sub" => "test_3",
    };
    for (keys %$h) {
	print "$_: $h->{$_}\r\n";
    }
    print "\r\n";
    print "3";
}

sub test_4 {
    my $h = {
	"Content-type" => "text/plain",
	"X-sub" => "test_4",
    };
    for (keys %$h) {
	print "$_", ": ", $h->{$_}, "\r\n";
#	print "$_", ": ", $h->{$_};
#	print "\r\n";
    }
    print "\r\n4";
}

sub test_5 {
    print <<EOF;
X-Message: parsethis
Content-type: text/html

A
B
C
D
EOF

}

sub test_syswrite_1 {
    test_syswrite(shift);
}

sub test_syswrite_2 {
    test_syswrite(shift,160);
}

sub test_syswrite_3 {
    test_syswrite(shift,80, 2000);
}

sub test_syswrite {
    my $r = shift;
    my $len = shift;
    my $offset = shift;
    my $msg = "";

#    my $m = "ENTERING test_syswrite ";
#    $m .= "LEN = $len " if $len;
#    $m .= "OFF = $offset" if $offset;
#    print STDERR $m, "\n";

    print "Status: 200 Bottles of beer on the wall\n",
    "X-Perl-Version: $]\n";
    print "X-Perl-Script: perlio.pl\n";
    print "X-Message: hello\n";
    print "Content-type: text/plain\n\n";

    for ('A'..'Z') {
	$msg .= $_ x 80;
    }
    my $bytes_sent = 
	defined($offset) ? syswrite STDOUT, $msg, $len, $offset :  
	 defined($len) ? syswrite STDOUT, $msg, $len : 
           syswrite STDOUT, $msg, length($msg);

    my $real_b = $r->bytes_sent;
    print "REAL Bytes sent = $real_b\n";
    die "Syswrite error. Bytes wrote=$bytes_sent. Real bytes sent = $real_b\n"
	unless $bytes_sent == $real_b;
}

sub test_syswrite_noheader {
    print STDERR "********* This is not a real error. Ignore. *********\n";
    my $msg = "1234WRITEmethod";
    syswrite STDOUT, $msg, 5, 4;
}