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.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

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

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 $nl = $opt{output} eq 'http-cgi' ? "\n" : "\x0D\x0A";
  binmode STDOUT;
  $| = 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 "Location: $self->{redirect_uri}$nl";
    $status_code = 302
      if ($status_code == 303 || $status_code == 307)
      && (($main::ENV{SERVER_PROTOCOL} eq 'HTTP/1.0') ## TODO: use common interface
          || ($self->{wiki}->{var}->{client}->{user_agent_name}
                      =~ m#M(?:ozilla/[0-4]\.|icrosoft Internet Explorer)#));
  }
  if ($opt{output} eq 'http-cgi') {
    print "Status: $status_code $status_phrase$nl";
  } else {
    print "$status_code $status_phrase HTTP/1.1$nl";
  }
  
  for (@{$self->{header_field}}) {
    print "$_->{name}: $_->{body}$nl";
  }
  
  my $time = time;
  print "Date: @{[scalar gmtime $time]}$nl";
  if (defined $self->{expires_delta}) {
    print "Expires: @{[scalar gmtime ($time + $self->{expires_delta})]}$nl";
  }
  if (defined $self->{lastmodified_time}) {
    print "Last-Modified: @{[scalar gmtime $self->{lastmodified_time}]}$nl";
  } else {
    print "Last-Modified: @{[scalar gmtime $time]}$nl";
  }
  print "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 (($mt eq 'application/rdf+xml')
      && (index ($self->{wiki}->{var}->{client}->{user_agent_name},
                 'Gecko') > -1)) {
    print "Content-Type: application/xml";
  } else {
    print "Content-Type: $mt";
  }
  if ($charset) {
    if ($self->{wiki}->{var}->{client}->{user_agent_name}
        =~ m#Mozilla/[12]\.#) {
      print qq(; charset="@{[{qw/euc-jp x-euc-jp shift_jis x-sjis/}
                             ->{$charset}
                             || $charset]}");
    } elsif ($self->{wiki}->{var}->{client}->{user_agent_name}
             =~ m#Mozilla/0\.|Infomosaic#) {
    } else {
      print qq(; charset="$charset");
    }
  }
  print $nl;
  
  for (join ', ', @{$self->{entity}->{language}||[]}) {
    print "Content-Language: $_$nl" if $_;
  }
  print "Content-Length: @{[length $body]}$nl";
  print $nl;
  print $body;
}

=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/10/05 11:55:29 $
1	wakaba	1.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	wakaba	1.2	our $VERSION = do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17	wakaba	1.1
18			my %Status = (
19			200 => q(OK),
20	wakaba	1.2	201 => q(Created),
21			202 => q(Accepted),
22			203 => q(Non-Authoritative Information),
23			204 => q(No Content),
24			205 => q(Reset Content),
25			250 => q(Low on Storage Space), # RTSP
26			300 => q(Multiple Choices),
27			301 => q(Moved Permanently),
28	wakaba	1.1	302 => q(Found),
29			303 => q(See Other),
30	wakaba	1.2	304 => q(Not Modified),
31			307 => q(Moved Temporarily),
32			400 => q(Bad Request),
33			401 => q(Unauthorized),
34	wakaba	1.1	403 => q(Forbidden),
35			404 => q(Not Found),
36	wakaba	1.2	405 => q(Method Not Allowed),
37			406 => q(Not Acceptable),
38			408 => q(Request Timeout),
39			409 => q(Conflict),
40			410 => q(Gone),
41			413 => q(Request Entity Too Long),
42			414 => q(Request-URI Too Long),
43			415 => q(Unsupported Media Type),
44			423 => q(Locked),
45			480 => q(Temporariliy Not Available), # SIP
46	wakaba	1.1	500 => q(Internal Server Error),
47	wakaba	1.2	501 => q(Not Implemented),
48			503 => q(Service Unavailable),
49			505 => q(HTTP Version Not Supported),
50			507 => q(Insufficient Storage),
51	wakaba	1.1	);
52	wakaba	1.2	my %Body = (
53			301 => sub {
54			my $self = shift;
55			my $euri = $self->{redirect_uri};
56			$euri =~ s/&/&/g;
57			$euri =~ s/</</g;
58			$euri =~ s/>/>/g;
59			$euri =~ s/"/"/g;
60			qq(<!DOCTYPE p SYSTEM><p>See <<a href="$euri">$euri</a>></p>);
61			},
62			);
63			$Body{302} = $Body{301};
64			$Body{303} = $Body{301};
65			$Body{307} = $Body{301};
66	wakaba	1.1
67			=head1 METHODS
68
69			=over 4
70
71			=item $http = SuikaWiki::Output::HTTP->new
72
73			Constructs new instance of HTTP output implementation
74
75			=cut
76
77			sub new ($;%) {
78			my $self = bless {header_field => [],
79			negotiate_header_field => {Negotiate => 1},
80			entity => {language => [],
81			media_type => 'application/octet-stream'},
82			}, shift;
83			my %opt = @_;
84	wakaba	1.2	$self->{wiki} = ref $opt{wiki} ? $opt{wiki} : $opt{view}->{wiki};
85	wakaba	1.1	$self->{view} = $opt{view};
86			$self->{viewobj} = $opt{viewobj};
87			$self;
88			}
89
90			sub add_header_field ($$$;%) {
91			my ($self, $name => $body, %opt) = @_;
92			push @{$self->{header_field}}, {name => $name, body => $body};
93			}
94
95			sub add_negotiate_header_field ($$) {
96			my ($self, $name) = @_;
97			$self->{negotiate_header_field}->{$name} = 1;
98			}
99
100			sub set_expires ($%) {
101			my ($self, %opt) = @_;
102			if ($opt{time}) {
103			## TODO: use rfc1123-time
104			push @{$self->{header_field}}, {name => 'Expires',
105			body => scalar gmtime $opt{time}};
106			} elsif (defined $opt{delta}) {
107			$self->{expires_delta} = $opt{delta} + 0;
108			}
109			}
110
111	wakaba	1.2	sub set_redirect ($%) {
112			my ($self, %opt) = @_;
113			$self->{redirect_uri} = $opt{uri};
114			if ($opt{status_code}) {
115			$self->{status_code} = $opt{status_code};
116			} else {
117			$self->{status_code} = 302;
118			}
119			$self->{status_phrase} = $opt{status_phrase};
120	wakaba	1.1	}
121
122			sub set_last_modified ($%) {
123			my ($self, %opt) = @_;
124			$self->{lastmodified_time} = $opt{time};
125			}
126
127			sub append_to_body ($$) {
128			my ($self, $s) = @_;
129			$self->{entity}->{body} .= $s;
130			}
131
132			sub output ($;%) {
133			my ($self, %opt) = @_;
134	wakaba	1.2	my $nl = $opt{output} eq 'http-cgi' ? "\n" : "\x0D\x0A";
135	wakaba	1.1	binmode STDOUT;
136			$\| = 1;
137	wakaba	1.2
138			my $status_code = $self->{status_code} \|\| 200;
139			my $status_phrase = $self->{status_phrase} \|\| $Status{$status_code};
140			if ((300 < $status_code) && ($status_code < 400)
141			&& (defined $self->{redirect_uri})) {
142			print "Location: $self->{redirect_uri}$nl";
143			$status_code = 302
144			if ($status_code == 303 \|\| $status_code == 307)
145			&& (($main::ENV{SERVER_PROTOCOL} eq 'HTTP/1.0') ## TODO: use common interface
146			\|\| ($self->{wiki}->{var}->{client}->{user_agent_name}
147			=~ m#M(?:ozilla/[0-4]\.\|icrosoft Internet Explorer)#));
148			}
149	wakaba	1.1	if ($opt{output} eq 'http-cgi') {
150	wakaba	1.2	print "Status: $status_code $status_phrase$nl";
151	wakaba	1.1	} else {
152	wakaba	1.2	print "$status_code $status_phrase HTTP/1.1$nl";
153	wakaba	1.1	}
154
155			for (@{$self->{header_field}}) {
156			print "$_->{name}: $_->{body}$nl";
157			}
158
159			my $time = time;
160			print "Date: @{[scalar gmtime $time]}$nl";
161			if (defined $self->{expires_delta}) {
162			print "Expires: @{[scalar gmtime ($time + $self->{expires_delta})]}$nl";
163			}
164			if (defined $self->{lastmodified_time}) {
165			print "Last-Modified: @{[scalar gmtime $self->{lastmodified_time}]}$nl";
166			} else {
167			print "Last-Modified: @{[scalar gmtime $time]}$nl";
168			}
169			print "Vary: ".join (', ', keys %{$self->{negotiate_header_field}})."$nl";
170
171	wakaba	1.2	my $mt = $self->{entity}->{media_type} \|\| 'application/octet-stream';
172			my $charset = $self->{entity}->{charset};
173	wakaba	1.1	my $body = '' . $self->{entity}->{body};
174	wakaba	1.2	unless (length $body) {
175			$mt = q<text/html>;
176			$charset = 'iso-8859-1';
177			$body = &{$Body{$self->{status_code}\|\|200}\|\|sub{}} ($self);
178			}
179	wakaba	1.1	## TODO:
180			$body = &main::code_convert (\$body, $self->{entity}->{charset});
181
182	wakaba	1.2	if (($mt eq 'application/rdf+xml')
183			&& (index ($self->{wiki}->{var}->{client}->{user_agent_name},
184	wakaba	1.1	'Gecko') > -1)) {
185			print "Content-Type: application/xml";
186			} else {
187	wakaba	1.2	print "Content-Type: $mt";
188	wakaba	1.1	}
189	wakaba	1.2	if ($charset) {
190			if ($self->{wiki}->{var}->{client}->{user_agent_name}
191	wakaba	1.1	=~ m#Mozilla/[12]\.#) {
192			print qq(; charset="@{[{qw/euc-jp x-euc-jp shift_jis x-sjis/}
193	wakaba	1.2	->{$charset}
194			\|\| $charset]}");
195			} elsif ($self->{wiki}->{var}->{client}->{user_agent_name}
196	wakaba	1.1	=~ m#Mozilla/0\.\|Infomosaic#) {
197			} else {
198	wakaba	1.2	print qq(; charset="$charset");
199	wakaba	1.1	}
200			}
201			print $nl;
202
203			for (join ', ', @{$self->{entity}->{language}\|\|[]}) {
204			print "Content-Language: $_$nl" if $_;
205			}
206			print "Content-Length: @{[length $body]}$nl";
207			print $nl;
208			print $body;
209			}
210
211			=item $self->{entity}->{charset}
212			=item $self->{entity}->{language} = [...]
213			=item $self->{entity}->{media_type}
214
215			=back
216
217			=head1 TODO
218
219			Use manakai.
220
221			=head1 LICENSE
222
223			Copyright 2003 Wakaba <w@suika.fam.cx>
224
225			This program is free software; you can redistribute it and/or
226			modify it under the same terms as Perl itself.
227
228			=cut
229
230	wakaba	1.2	1; # $Date: 2003/10/05 11:55:29 $