", "all-long
", "failed
"; } # print file for undefined frames my $FRAME = open_die(">$self->{dir}/frame_undef.html"); print {$FRAME} make_html("FRAME", "FRAME"); close $FRAME; } sub global_end { my $self = shift; foreach (@{$self->{list_modes}}) { my ($handle, $index, $filename) = @$_; print $handle "\n\n"; close $handle; } } sub item_pre { #my ($self, $arg) = @_; } sub item_post_change { my ($self, $r, $arg, $index) = @_; $arg ||= $self->norm_args($r, $arg); $self -> item_write($r, $arg || {}, $index); } sub norm_args { my ($self, $r, $arg) = @_; return { fail => ($r->code() =~ m/[45]\d\d/) ? 1 : 0, method => $r->request()->method(), url => $r->request()->uri(), description => "THIRD PARTY USER", $arg ? (%$arg) : (), }; } sub item_post { my ($self, $r, $arg) = @_; my ($LIST_ALL, $LIST_FAIL, $LIST_ALL_LONG) = map {$_->[0]} @{$self->{list_modes}}; my $index = $self->{entry_count}++; $arg ||= $self->norm_args($r, $arg); $self -> item_write($r, $arg || {}, $index); print {$LIST_ALL} pr_index_item($r, $arg, $index, 0); print {$LIST_FAIL} pr_index_item($r, $arg, $index, 0) if $arg->{fail}; print {$LIST_ALL_LONG} pr_index_item($r, $arg, $index, 1); } # private sub item_write { my ($self, $r, $arg, $index) = @_; my $dir = $self->{dir} . "/" . $index; -d $dir || mkdir $dir || die "Can't make dir=$dir err=$!"; # FILE: Frameset containing (2), (3 4) my $INDEX = open_die(">$dir/index.html"); my $request_body_frame = ($r && $arg->{fail} != 2) ? "" : ""; print {$INDEX} make_html("Single Request", <
$fail_str $arg->{method} $url
EOF # print all called requests my $subrequest_count = 0; my $req = $r; while (defined $req) { print $PLANDATA "$req->{_rc}", "$SP", "$req->{_request}->{_uri}
\n"; $subrequest_count++; $req = $req -> {_previous}; } print {$PLANDATA} "
\n"; # print POST data if (defined $arg->{data} && %{$arg->{data}}) { my @tbl = map {[$_, $arg->{data}->{$_}]} sort keys %{$arg->{data}}; print {$PLANDATA} pr_table("Data section of GET or POST", ["Attribute", "Value"], \@tbl, alter_colors()); print $PLANDATA "
\n"; } # print assertions my $fail_out = $arg->{fail_str}; $fail_out = [ $fail_out ] if ! ref $fail_out; my @bool = qw(false true); my @failed = map { $_->[0] = $bool[$_->[0]] || $_->[0]; $_ } map { (my $tmp = $_) =~ s/\n"; print {$PLANDATA} "
/g; push @xpath, [$xpath_expr, $xpath_result]; } if (@xpath) { print {$PLANDATA} pr_table("XPath expressions", ["XPath", "Value"], \@xpath, alter_colors()); print $PLANDATA "
\n"; } } } # print variables that have been defined in this entry if (defined $arg->{new_properties} && scalar @{$arg->{new_properties}}) { print {$PLANDATA} pr_table("Defined variables", ["Name", "Value"], $arg->{new_properties}, alter_colors()); print $PLANDATA "
\n"; } # print caller pages if (my $cp = $arg->{caller_pages}) { print $PLANDATA "
This page was called by
\n";
foreach (@$cp) {
print $PLANDATA "$_
\n";
}
}
# print elapsed time
print $PLANDATA "Elapsed time: ", $r->elapsed_time(), " seconds
\n" if $r;
# Finish this frame
print $PLANDATA "\n";
close $PLANDATA;
# FILE: write frame(3): print all subrequests
$subrequest_count = 0;
$req = $r;
while (defined($req)) { # for all subrequests
# define and make directory
my $dir = "$self->{dir}/$index/$subrequest_count";
-d $dir || mkdir $dir || die "Can't make dir=$dir err=$!";
# write data for frame 3, request header
my $HEADER = open_die(">$dir/req_head.html");
my $xhtml_text0 = ($req->content_xhtml(1)) ?
"source-xhtml" : "";
my $navi_source = <
\n",
print_http_header(
"Request Header",
($req->{_request}->{_method} || "no_method") . $SP . ($req->{_request}->{_uri} || "no_uri"),
$req->{_request}->{_headers}
),
"
\n",
print_http_header(
"Response Header",
($req->{_protocol} || "(no_protocol)") . $SP .
"$req->{_rc}" . $SP .
($req->{_msg} || "(no_message)"),
$req->{_headers}
),
);
close $HEADER;
# FILE: write response body (source)
my $SRC = open_die(">$dir/source.txt");
print {$SRC} $req -> content();
close $SRC;
# FILE: write response body (xhtml source)
if ($req->content_xhtml(1)) { #if (exists $req->{_content_xhtml})
my $XSRC = open_die(">$dir/source_xhtml.txt");
print {$XSRC} $req -> content_xhtml();
close $XSRC;
}
# FILE: write frame(4): write display version
my $content_type = norm_content_type($req->{_headers}->{"content-type"});
my $DISPLAY = open_die(">$dir/display.html");
SWITCH: for (@{$content_type}) {
/text\/html/ and do {
my $frame = "../../frame_undef.html";
my $txt = $req -> content();
# in aendern
$txt =~ s/($txt
\n");
last;
};
/image\/gif/ and do {
print {$DISPLAY} make_html("", "
");
my $FILE = open_die(">$dir/display_1.gif");
print $FILE $req->{_content};
close $FILE;
last;
};
/image\/png/ and do {
print {$DISPLAY} make_html("", "
");
my $FILE = open_die(">$dir/display_1.png");
print $FILE $req->{_content};
close $FILE;
last;
};
/image\/jpeg/ and do {
print {$DISPLAY} make_html("", "
");
my $FILE = open_die(">$dir/display_1.jpeg");
print $FILE $req->{_content};
close $FILE;
last;
};
do { # else
# ??? kann ein array sein!
my ($type, $charset) = split(/; */,
$req->{_headers}->{"content-type"} || "", 2);
my $mime_info = "";
$mime_info .= "type='$type'" if $type;
$mime_info .= " $charset" if $charset;
my $FILE = open_die(">$dir/any-mime");
if ($mime_info eq "") {
print {$FILE} make_html("EMPTY", "... Content is empty ...
");
}
else {
my $txt = <
$firstline
$tmp_table
EOF
return $txt;
}
sub autoflush { #static
my ($handle) = @_;
my $save_handle = select($handle);
$| = 1;
select($save_handle);
}
sub new_handle {
do {local *FH; *FH};
}
sub open_die { #static
my ($filename) = @_;
my $handle = new_handle();
my ($package, $file, $line) = caller();
open($handle, $filename) or die("line $line: Can't open $filename, err=$!");
return $handle;
}
sub alter_colors { #static object factory
my @colors = @_;
#@colors = ("#E0E0E0", "#F3F3F3") if ! scalar @colors;
@colors = ("bgcolor='#E0E0E0'", "bgcolor='#F3F3F3'") if ! scalar @colors;
my $state = 0;
return sub {
$state = 0 if $state >= scalar @colors;
return $colors[$state++];
};
}
sub first_blue { #static object factory
my $state = 0;
return sub {
my $old_state = $state;
$state = 1;
return $old_state ? "black" : "blue";
};
}
sub make_html { # static
my ($title, @txt) = @_;
my $txt = join "", @txt;
return <