SuikaWiki/Output/HTTP.pm


=head1 NAME

SuikaWiki::Output::HTTP --- SuikaWiki: HTTP or HTTP CGI output support

=head1 DESCRIPTION

This module provides HTTP or HTTP CGI outputing support.

This module is part of SuikaWiki.

=cut

package SuikaWiki::Output::HTTP;
use strict;
our $VERSION = do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require IO::Handle;

my %Status = (
  200 => q(OK),
  201 => q(Created),
  202 => q(Accepted),
  203 => q(Non-Authoritative Information),
  204 => q(No Content),
  205 => q(Reset Content),
  250 => q(Low on Storage Space),  # RTSP
  300 => q(Multiple Choices),
  301 => q(Moved Permanently),
  302 => q(Found),
  303 => q(See Other),
  304 => q(Not Modified),
  307 => q(Moved Temporarily),
  400 => q(Bad Request),
  401 => q(Unauthorized),
  403 => q(Forbidden),
  404 => q(Not Found),
  405 => q(Method Not Allowed),
  406 => q(Not Acceptable),
  408 => q(Request Timeout),
  409 => q(Conflict),
  410 => q(Gone),
  413 => q(Request Entity Too Long),
  414 => q(Request-URI Too Long),
  415 => q(Unsupported Media Type),
  423 => q(Locked),
  480 => q(Temporariliy Not Available), # SIP
  500 => q(Internal Server Error),
  501 => q(Not Implemented),
  503 => q(Service Unavailable),
  505 => q(HTTP Version Not Supported),
  507 => q(Insufficient Storage),
);
my %Body = (
  301 => sub {
    my $self = shift;
    my $euri = $self->{redirect_uri};
    $euri =~ s/&/&amp;/g;
    $euri =~ s/</&lt;/g;
    $euri =~ s/>/&gt;/g;
    $euri =~ s/"/&quot;/g;
    qq(<!DOCTYPE p SYSTEM><p>See &lt;<a href="$euri">$euri</a>&gt;</p>);
  },
);
$Body{302} = $Body{301};
$Body{303} = $Body{301};
$Body{307} = $Body{301};

=head1 METHODS

=over 4

=item $http = SuikaWiki::Output::HTTP->new

Constructs new instance of HTTP output implementation

=cut

sub new ($;%) {
  my $self = bless {header_field => [],
                    negotiate_header_field => {Negotiate => 1},
                    entity => {language => [], 
                               media_type => 'application/octet-stream'},
                   }, shift;
  my %opt = @_;
  $self->{wiki} = ref $opt{wiki} ? $opt{wiki} : $opt{view}->{wiki};
  $self->{view} = $opt{view};
  $self->{viewobj} = $opt{viewobj};
  $self->{-out_handle} = $opt{output_handle} || *STDOUT;
  $self;
}

sub add_header_field ($$$;%) {
  my ($self, $name => $body, %opt) = @_;
  push @{$self->{header_field}}, {name => $name, body => $body};
}

sub add_negotiate_header_field ($$) {
  my ($self, $name) = @_;
  $self->{negotiate_header_field}->{$name} = 1;
}

sub set_expires ($%) {
  my ($self, %opt) = @_;
  if ($opt{time}) {
    ## TODO: use rfc1123-time
    push @{$self->{header_field}}, {name => 'Expires', 
                                    body => scalar gmtime $opt{time}};
  } elsif (defined $opt{delta}) {
    $self->{expires_delta} = $opt{delta} + 0;
  }
}

sub set_redirect ($%) {
  my ($self, %opt) = @_;
  $self->{redirect_uri} = $opt{uri};
  if ($opt{status_code}) {
    $self->{status_code} = $opt{status_code};
  } else {
    $self->{status_code} = 302;
  }
  $self->{status_phrase} = $opt{status_phrase};
}

sub set_last_modified ($%) {
  my ($self, %opt) = @_;
  $self->{lastmodified_time} = $opt{time};
}

sub append_to_body ($$) {
  my ($self, $s) = @_;
  $self->{entity}->{body} .= $s;
}

sub output ($;%) {
  my ($self, %opt) = @_;
  my $dg = $self->{wiki}->{var}->{client}->{downgrade};
  ## Note: CGI/1.1 draft 3 recommends ("SHOULD") that
  ##       "\x0A" should be used as new line in AmigaDOS and Un*x environments.
  my $nl = $opt{output} eq 'http-cgi' ? "\n" : "\x0D\x0A";
  my $out = $opt{output_handle} || $self->{-out_handle};
  binmode $out;
  $out->autoflush (1);

  my $status_code = $self->{status_code} || 200;
  my $status_phrase = $self->{status_phrase} || $Status{$status_code};
  if ((300 < $status_code) && ($status_code < 400)
   && (defined $self->{redirect_uri})) {
    print $out "Location: $self->{redirect_uri}$nl";
    $status_code = 302
      if 
            ($status_code == 303 or $status_code == 307)
        and (   (    $self->{wiki}->{input}->meta_variable ('SERVER_PROTOCOL')
                  eq 'HTTP/1.0')
             or $dg->{http_no_see_other});
  }
  if ($opt{output} eq 'http-cgi') {
    print $out "Status: $status_code $status_phrase$nl";
  } else {
    print $out "$status_code $status_phrase HTTP/1.1$nl";
  }
  
  for (@{$self->{header_field}}) {
    print $out "$_->{name}: $_->{body}$nl";
  }
  
  my $time = time;
  print $out "Date: @{[scalar gmtime $time]}$nl";
  if (defined $self->{expires_delta}) {
    print $out "Expires: @{[scalar gmtime ($time + $self->{expires_delta})]}$nl";
  }
  if (defined $self->{lastmodified_time}) {
    print $out "Last-Modified: @{[scalar gmtime $self->{lastmodified_time}]}$nl";
  } else {
    print $out "Last-Modified: @{[scalar gmtime $time]}$nl";
  }
  print $out "Vary: ".join (', ', keys %{$self->{negotiate_header_field}})."$nl";
  
  my $mt = $self->{entity}->{media_type} || 'application/octet-stream';
  my $charset = $self->{entity}->{charset};
  my $body = '' . $self->{entity}->{body};
  unless (length $body) {
    $mt = q<text/html>;
    $charset = 'iso-8859-1';
    $body = &{$Body{$self->{status_code}||200}||sub{}} ($self);
  }
  ## TODO:
  $body = &main::code_convert (\$body, $self->{entity}->{charset});
  
  if (substr ($mt, -4) eq '+xml') {
    if ($mt eq 'application/rdf+xml' and $dg->{media_type_no_rdf_plus_xml}) {
      print $out "Content-Type: application/xml";
    } elsif ($dg->{media_type_no_plus_xml}) {
      print $out "Content-Type: application/xml";
    } elsif ($dg->{media_type_no_xml}) {
      print $out "Content-Type: text/plain";
    } else {
      print $out "Content-Type: $mt";
    }
  } else {
    print $out "Content-Type: $mt";
  }
  if ($charset) {
    if ($dg->{media_type_no_parameter}) {
      
    } elsif ($dg->{charset_name_with_x}) {
      print $out qq(; charset="@{[{qw/euc-jp x-euc-jp shift_jis x-sjis/}
                                 ->{$charset} or $charset]}");
    } else {
      print $out qq(; charset=).$self->___quote_word ($charset);
    }
  }
  print $nl;
  
  for (join ', ', @{$self->{entity}->{language}||[]}) {
    print $out "Content-Language: $_$nl" if $_;
  }
  print $out "Content-Length: @{[length $body]}$nl";
  print $out $nl;
  print $out $body;
}

## Note: CGI/1.1 draft 3 does not allow HTTP Header Fields
##       when Location: field is outputed.  This module does
##       NOT follow that requirement.  The draft allows
##       message-body explicitly, even if there is Location:.
##       Therefore at least entity-header fields should be allowed.

## TODO: REDIRECT_URI support

=item $self->exit

Declares the instance ($self) no longer considered useful.

=cut

sub exit ($) {
  my $self = shift;
  delete $self->{wiki};
  delete $self->{view};
  delete $self->{viewobj};
  $self->{exited} = 1;
}

sub DESTROY ($) {
  my $self = shift;
  $self->exit unless $self->{exited};
}

sub ___quote_word ($$) {
  my ($self, $s) = @_;
  if ($s =~ /[^0-9A-Za-z_.+-]/) {
    $s =~ s/([\\"])/\\$1/g;
    return qq<"$s">;
  } else {
    return $s;
  }
}

=item $self->{entity}->{charset}
=item $self->{entity}->{language} = [...]
=item $self->{entity}->{media_type}

=back

=head1 TODO

Use manakai.

=head1 LICENSE

Copyright 2003 Wakaba <w@suika.fam.cx>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2003/12/26 06:48:09 $
1
2	=head1 NAME
3
4	SuikaWiki::Output::HTTP --- SuikaWiki: HTTP or HTTP CGI output support
5
6	=head1 DESCRIPTION
7
8	This module provides HTTP or HTTP CGI outputing support.
9
10	This module is part of SuikaWiki.
11
12	=cut
13
14	package SuikaWiki::Output::HTTP;
15	use strict;
16	our $VERSION = do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17	require IO::Handle;
18
19	my %Status = (
20	200 => q(OK),
21	201 => q(Created),
22	202 => q(Accepted),
23	203 => q(Non-Authoritative Information),
24	204 => q(No Content),
25	205 => q(Reset Content),
26	250 => q(Low on Storage Space), # RTSP
27	300 => q(Multiple Choices),
28	301 => q(Moved Permanently),
29	302 => q(Found),
30	303 => q(See Other),
31	304 => q(Not Modified),
32	307 => q(Moved Temporarily),
33	400 => q(Bad Request),
34	401 => q(Unauthorized),
35	403 => q(Forbidden),
36	404 => q(Not Found),
37	405 => q(Method Not Allowed),
38	406 => q(Not Acceptable),
39	408 => q(Request Timeout),
40	409 => q(Conflict),
41	410 => q(Gone),
42	413 => q(Request Entity Too Long),
43	414 => q(Request-URI Too Long),
44	415 => q(Unsupported Media Type),
45	423 => q(Locked),
46	480 => q(Temporariliy Not Available), # SIP
47	500 => q(Internal Server Error),
48	501 => q(Not Implemented),
49	503 => q(Service Unavailable),
50	505 => q(HTTP Version Not Supported),
51	507 => q(Insufficient Storage),
52	);
53	my %Body = (
54	301 => sub {
55	my $self = shift;
56	my $euri = $self->{redirect_uri};
57	$euri =~ s/&/&/g;
58	$euri =~ s/</</g;
59	$euri =~ s/>/>/g;
60	$euri =~ s/"/"/g;
61	qq(<!DOCTYPE p SYSTEM><p>See <<a href="$euri">$euri</a>></p>);
62	},
63	);
64	$Body{302} = $Body{301};
65	$Body{303} = $Body{301};
66	$Body{307} = $Body{301};
67
68	=head1 METHODS
69
70	=over 4
71
72	=item $http = SuikaWiki::Output::HTTP->new
73
74	Constructs new instance of HTTP output implementation
75
76	=cut
77
78	sub new ($;%) {
79	my $self = bless {header_field => [],
80	negotiate_header_field => {Negotiate => 1},
81	entity => {language => [],
82	media_type => 'application/octet-stream'},
83	}, shift;
84	my %opt = @_;
85	$self->{wiki} = ref $opt{wiki} ? $opt{wiki} : $opt{view}->{wiki};
86	$self->{view} = $opt{view};
87	$self->{viewobj} = $opt{viewobj};
88	$self->{-out_handle} = $opt{output_handle} \|\| *STDOUT;
89	$self;
90	}
91
92	sub add_header_field ($$$;%) {
93	my ($self, $name => $body, %opt) = @_;
94	push @{$self->{header_field}}, {name => $name, body => $body};
95	}
96
97	sub add_negotiate_header_field ($$) {
98	my ($self, $name) = @_;
99	$self->{negotiate_header_field}->{$name} = 1;
100	}
101
102	sub set_expires ($%) {
103	my ($self, %opt) = @_;
104	if ($opt{time}) {
105	## TODO: use rfc1123-time
106	push @{$self->{header_field}}, {name => 'Expires',
107	body => scalar gmtime $opt{time}};
108	} elsif (defined $opt{delta}) {
109	$self->{expires_delta} = $opt{delta} + 0;
110	}
111	}
112
113	sub set_redirect ($%) {
114	my ($self, %opt) = @_;
115	$self->{redirect_uri} = $opt{uri};
116	if ($opt{status_code}) {
117	$self->{status_code} = $opt{status_code};
118	} else {
119	$self->{status_code} = 302;
120	}
121	$self->{status_phrase} = $opt{status_phrase};
122	}
123
124	sub set_last_modified ($%) {
125	my ($self, %opt) = @_;
126	$self->{lastmodified_time} = $opt{time};
127	}
128
129	sub append_to_body ($$) {
130	my ($self, $s) = @_;
131	$self->{entity}->{body} .= $s;
132	}
133
134	sub output ($;%) {
135	my ($self, %opt) = @_;
136	my $dg = $self->{wiki}->{var}->{client}->{downgrade};
137	## Note: CGI/1.1 draft 3 recommends ("SHOULD") that
138	## "\x0A" should be used as new line in AmigaDOS and Un*x environments.
139	my $nl = $opt{output} eq 'http-cgi' ? "\n" : "\x0D\x0A";
140	my $out = $opt{output_handle} \|\| $self->{-out_handle};
141	binmode $out;
142	$out->autoflush (1);
143
144	my $status_code = $self->{status_code} \|\| 200;
145	my $status_phrase = $self->{status_phrase} \|\| $Status{$status_code};
146	if ((300 < $status_code) && ($status_code < 400)
147	&& (defined $self->{redirect_uri})) {
148	print $out "Location: $self->{redirect_uri}$nl";
149	$status_code = 302
150	if
151	($status_code == 303 or $status_code == 307)
152	and ( ( $self->{wiki}->{input}->meta_variable ('SERVER_PROTOCOL')
153	eq 'HTTP/1.0')
154	or $dg->{http_no_see_other});
155	}
156	if ($opt{output} eq 'http-cgi') {
157	print $out "Status: $status_code $status_phrase$nl";
158	} else {
159	print $out "$status_code $status_phrase HTTP/1.1$nl";
160	}
161
162	for (@{$self->{header_field}}) {
163	print $out "$_->{name}: $_->{body}$nl";
164	}
165
166	my $time = time;
167	print $out "Date: @{[scalar gmtime $time]}$nl";
168	if (defined $self->{expires_delta}) {
169	print $out "Expires: @{[scalar gmtime ($time + $self->{expires_delta})]}$nl";
170	}
171	if (defined $self->{lastmodified_time}) {
172	print $out "Last-Modified: @{[scalar gmtime $self->{lastmodified_time}]}$nl";
173	} else {
174	print $out "Last-Modified: @{[scalar gmtime $time]}$nl";
175	}
176	print $out "Vary: ".join (', ', keys %{$self->{negotiate_header_field}})."$nl";
177
178	my $mt = $self->{entity}->{media_type} \|\| 'application/octet-stream';
179	my $charset = $self->{entity}->{charset};
180	my $body = '' . $self->{entity}->{body};
181	unless (length $body) {
182	$mt = q<text/html>;
183	$charset = 'iso-8859-1';
184	$body = &{$Body{$self->{status_code}\|\|200}\|\|sub{}} ($self);
185	}
186	## TODO:
187	$body = &main::code_convert (\$body, $self->{entity}->{charset});
188
189	if (substr ($mt, -4) eq '+xml') {
190	if ($mt eq 'application/rdf+xml' and $dg->{media_type_no_rdf_plus_xml}) {
191	print $out "Content-Type: application/xml";
192	} elsif ($dg->{media_type_no_plus_xml}) {
193	print $out "Content-Type: application/xml";
194	} elsif ($dg->{media_type_no_xml}) {
195	print $out "Content-Type: text/plain";
196	} else {
197	print $out "Content-Type: $mt";
198	}
199	} else {
200	print $out "Content-Type: $mt";
201	}
202	if ($charset) {
203	if ($dg->{media_type_no_parameter}) {
204
205	} elsif ($dg->{charset_name_with_x}) {
206	print $out qq(; charset="@{[{qw/euc-jp x-euc-jp shift_jis x-sjis/}
207	->{$charset} or $charset]}");
208	} else {
209	print $out qq(; charset=).$self->___quote_word ($charset);
210	}
211	}
212	print $nl;
213
214	for (join ', ', @{$self->{entity}->{language}\|\|[]}) {
215	print $out "Content-Language: $_$nl" if $_;
216	}
217	print $out "Content-Length: @{[length $body]}$nl";
218	print $out $nl;
219	print $out $body;
220	}
221
222	## Note: CGI/1.1 draft 3 does not allow HTTP Header Fields
223	## when Location: field is outputed. This module does
224	## NOT follow that requirement. The draft allows
225	## message-body explicitly, even if there is Location:.
226	## Therefore at least entity-header fields should be allowed.
227
228	## TODO: REDIRECT_URI support
229
230	=item $self->exit
231
232	Declares the instance ($self) no longer considered useful.
233
234	=cut
235
236	sub exit ($) {
237	my $self = shift;
238	delete $self->{wiki};
239	delete $self->{view};
240	delete $self->{viewobj};
241	$self->{exited} = 1;
242	}
243
244	sub DESTROY ($) {
245	my $self = shift;
246	$self->exit unless $self->{exited};
247	}
248
249	sub ___quote_word ($$) {
250	my ($self, $s) = @_;
251	if ($s =~ /[^0-9A-Za-z_.+-]/) {
252	$s =~ s/([\\"])/\\$1/g;
253	return qq<"$s">;
254	} else {
255	return $s;
256	}
257	}
258
259	=item $self->{entity}->{charset}
260	=item $self->{entity}->{language} = [...]
261	=item $self->{entity}->{media_type}
262
263	=back
264
265	=head1 TODO
266
267	Use manakai.
268
269	=head1 LICENSE
270
271	Copyright 2003 Wakaba <w@suika.fam.cx>
272
273	This program is free software; you can redistribute it and/or
274	modify it under the same terms as Perl itself.
275
276	=cut
277
278	1; # $Date: 2003/12/26 06:48:09 $