/[pub]/suikawiki/script/lib/SuikaWiki/Output/HTTP.pm
Suika

Diff of /suikawiki/script/lib/SuikaWiki/Output/HTTP.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by wakaba, Sun Oct 5 11:55:29 2003 UTC revision 1.5 by wakaba, Fri Jan 16 08:03:39 2004 UTC
# Line 14  This module is part of SuikaWiki. Line 14  This module is part of SuikaWiki.
14  package SuikaWiki::Output::HTTP;  package SuikaWiki::Output::HTTP;
15  use strict;  use strict;
16  our $VERSION = do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  our $VERSION = do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17    require IO::Handle;
18    
19  my %Status = (  my %Status = (
20    200 => q(OK),    200 => q(OK),
21    301 => q(Permanently Redirect),    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),    302 => q(Found),
30    303 => q(See Other),    303 => q(See Other),
31    307 => q(Temporary Redirect),    304 => q(Not Modified),
32    401 => q(Authorization Required),    307 => q(Moved Temporarily),
33      400 => q(Bad Request),
34      401 => q(Unauthorized),
35    403 => q(Forbidden),    403 => q(Forbidden),
36    404 => q(Not Found),    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),    500 => q(Internal Server Error),
48    503 => q(Service Temporary Unavailable),    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/</&lt;/g;
59        $euri =~ s/>/&gt;/g;
60        $euri =~ s/"/&quot;/g;
61        qq(<!DOCTYPE p SYSTEM><p>See &lt;<a href="$euri">$euri</a>&gt;</p>);
62      },
63    );
64    $Body{302} = $Body{301};
65    $Body{303} = $Body{301};
66    $Body{307} = $Body{301};
67    
68  =head1 METHODS  =head1 METHODS
69    
# Line 45  sub new ($;%) { Line 82  sub new ($;%) {
82                                 media_type => 'application/octet-stream'},                                 media_type => 'application/octet-stream'},
83                     }, shift;                     }, shift;
84    my %opt = @_;    my %opt = @_;
85    $self->{wiki} = $opt{wiki};    $self->{wiki} = ref $opt{wiki} ? $opt{wiki} : $opt{view}->{wiki};
86    $self->{view} = $opt{view};    $self->{view} = $opt{view};
87    $self->{viewobj} = $opt{viewobj};    $self->{viewobj} = $opt{viewobj};
88      $self->{-out_handle} = $opt{output_handle} || *STDOUT;
89    $self;    $self;
90  }  }
91    
# Line 72  sub set_expires ($%) { Line 110  sub set_expires ($%) {
110    }    }
111  }  }
112    
113  sub set_redirect_uri ($%) {  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 ($%) {  sub set_last_modified ($%) {
# Line 88  sub append_to_body ($$) { Line 133  sub append_to_body ($$) {
133    
134  sub output ($;%) {  sub output ($;%) {
135    my ($self, %opt) = @_;    my ($self, %opt) = @_;
136    my $nl;    my $dg = $self->{wiki}->{var}->{client}->{downgrade};
137    binmode STDOUT;    ## Note: CGI/1.1 draft 3 recommends ("SHOULD") that
138    $| = 1;    ##       "\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 $status = qq(@{[$self->{status_code}||200]} @{[$self->{status_phrase}||$Status{$self->{status_code}||200}]});    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') {    if ($opt{output} eq 'http-cgi') {
157      $nl = "\n";      print $out "Status: $status_code $status_phrase$nl";
     print "Status: $status$nl";  
158    } else {    } else {
159      $nl = "\x0D\x0A";      print $out "$status_code $status_phrase HTTP/1.1$nl";
     print "$status HTTP/1.1$nl";  
160    }    }
161        
162    for (@{$self->{header_field}}) {    for (@{$self->{header_field}}) {
163      print "$_->{name}: $_->{body}$nl";      print $out "$_->{name}: $_->{body}$nl";
164    }    }
165        
166    my $time = time;    my $time = time;
167    print "Date: @{[scalar gmtime $time]}$nl";    print $out "Date: @{[scalar gmtime $time]}$nl";
168    if (defined $self->{expires_delta}) {    if (defined $self->{expires_delta}) {
169      print "Expires: @{[scalar gmtime ($time + $self->{expires_delta})]}$nl";      print $out "Expires: @{[scalar gmtime ($time + $self->{expires_delta})]}$nl";
170    }    }
171    if (defined $self->{lastmodified_time}) {    if (defined $self->{lastmodified_time}) {
172      print "Last-Modified: @{[scalar gmtime $self->{lastmodified_time}]}$nl";      print $out "Last-Modified: @{[scalar gmtime $self->{lastmodified_time}]}$nl";
173    } else {    } else {
174      print "Last-Modified: @{[scalar gmtime $time]}$nl";      print $out "Last-Modified: @{[scalar gmtime $time]}$nl";
175    }    }
176    print "Vary: ".join (', ', keys %{$self->{negotiate_header_field}})."$nl";    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};    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:    ## TODO:
187    $body = &main::code_convert (\$body, $self->{entity}->{charset});    $body = &main::code_convert (\$body, $self->{entity}->{charset});
188        
189    if (($self->{entity}->{media_type} eq 'application/rdf+xml')    if (substr ($mt, -4) eq '+xml') {
190        && (index ($self->{view}->{wiki}->{var}->{client}->{user_agent_name},      if ($mt eq 'application/rdf+xml' and $dg->{media_type_no_rdf_plus_xml}) {
191                   'Gecko') > -1)) {        print $out "Content-Type: application/xml";
192      print "Content-Type: application/xml";      } 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 {    } else {
200      print "Content-Type: $self->{entity}->{media_type}";      print $out "Content-Type: $mt";
201    }    }
202    if ($self->{entity}->{charset}) {    if ($charset) {
203      if ($self->{view}->{wiki}->{var}->{client}->{user_agent_name}      if ($dg->{media_type_no_parameter}) {
204          =~ m#Mozilla/[12]\.#) {        
205        print qq(; charset="@{[{qw/euc-jp x-euc-jp shift_jis x-sjis/}      } elsif ($dg->{charset_name_with_x}) {
206                               ->{$self->{entity}->{charset}}        print $out qq(; charset="@{[{qw/euc-jp x-euc-jp shift_jis x-sjis/}
207                               || $self->{entity}->{charset}]}");                                   ->{$charset} or $charset]}");
     } elsif ($self->{view}->{wiki}->{var}->{client}->{user_agent_name}  
              =~ m#Mozilla/0\.|Infomosaic#) {  
208      } else {      } else {
209        print qq(; charset="$self->{entity}->{charset}");        print $out qq(; charset=).$self->___quote_word ($charset);
210      }      }
211    }    }
212    print $nl;    print $nl;
213        
214    for (join ', ', @{$self->{entity}->{language}||[]}) {    for (join ', ', @{$self->{entity}->{language}||[]}) {
215      print "Content-Language: $_$nl" if $_;      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    }    }
   print "Content-Length: @{[length $body]}$nl";  
   print $nl;  
   print $body;  
257  }  }
258    
259  =item $self->{entity}->{charset}  =item $self->{entity}->{charset}
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.5
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24