/[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.4 by wakaba, Fri Dec 26 06:48:09 2003 UTC revision 1.6 by wakaba, Sun Feb 8 08:55:45 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),
# Line 84  sub new ($;%) { Line 85  sub new ($;%) {
85    $self->{wiki} = ref $opt{wiki} ? $opt{wiki} : $opt{view}->{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 131  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 $dg = $self->{wiki}->{var}->{client}->{downgrade};
137    ## Note: CGI/1.1 draft 3 recommends ("SHOULD") that    ## Note: CGI/1.1 draft 3 recommends ("SHOULD") that
138    ##       "\x0A" should be used as new line in AmigaDOS and Un*x environments.    ##       "\x0A" should be used as new line in AmigaDOS and Un*x environments.
139    my $nl = $opt{output} eq 'http-cgi' ? "\n" : "\x0D\x0A";    my $nl = $opt{output} eq 'http-cgi' ? "\n" : "\x0D\x0A";
140    binmode STDOUT;    my $out = $opt{output_handle} || $self->{-out_handle};
141    $| = 1;    binmode $out;
142      $out->autoflush (1);
143    
144    my $status_code = $self->{status_code} || 200;    my $status_code = $self->{status_code} || 200;
145    my $status_phrase = $self->{status_phrase} || $Status{$status_code};    my $status_phrase = $self->{status_phrase} || $Status{$status_code};
146    if ((300 < $status_code) && ($status_code < 400)    if ((300 < $status_code) && ($status_code < 400)
147     && (defined $self->{redirect_uri})) {     && (defined $self->{redirect_uri})) {
148      print "Location: $self->{redirect_uri}$nl";      print $out "Location: $self->{redirect_uri}$nl";
149      $status_code = 302      $status_code = 302
150        if ($status_code == 303 || $status_code == 307)        if
151        && (($main::ENV{SERVER_PROTOCOL} eq 'HTTP/1.0') ## TODO: use common interface              ($status_code == 303 or $status_code == 307)
152            || ($self->{wiki}->{var}->{client}->{user_agent_name}          and (   (    $self->{wiki}->{input}->meta_variable ('SERVER_PROTOCOL')
153                        =~ m#M(?:ozilla/[0-4]\.|icrosoft Internet Explorer)#));                    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      print "Status: $status_code $status_phrase$nl";      print $out "Status: $status_code $status_phrase$nl";
158    } else {    } else {
159      print "$status_code $status_phrase HTTP/1.1$nl";      print $out "$status_code $status_phrase 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';    my $mt = $self->{entity}->{media_type} || 'application/octet-stream';
179    my $charset = $self->{entity}->{charset};    my $charset = $self->{entity}->{charset};
180    my $body = '' . $self->{entity}->{body};    my $body = '' . $self->{entity}->{body};
181    unless (length $body) {    if (not length $body and $self->{status_code} != 200) {
182      $mt = q<text/html>;      $mt = q<text/html>;
183      $charset = 'iso-8859-1';      $charset = 'iso-8859-1';
184      $body = &{$Body{$self->{status_code}||200}||sub{}} ($self);      $body = ($Body{$self->{status_code}} or sub{})->($self);
185    }    }
186    ## TODO:    ## TODO:
187    $body = &main::code_convert (\$body, $self->{entity}->{charset});    $body = &main::code_convert (\$body, $self->{entity}->{charset},
188                                   $self->{wiki}->{config}->{charset}->{internal})
189        unless $self->{entity}->{body_is_octet_stream};
190        
191    if (($mt eq 'application/rdf+xml')    if (substr ($mt, -4) eq '+xml') {
192        && (index ($self->{wiki}->{var}->{client}->{user_agent_name},      if ($mt eq 'application/rdf+xml' and $dg->{media_type_no_rdf_plus_xml}) {
193                   'Gecko') > -1)) {        print $out "Content-Type: application/xml";
194      print "Content-Type: application/xml";      } elsif ($dg->{media_type_no_plus_xml}) {
195          print $out "Content-Type: application/xml";
196        } elsif ($dg->{media_type_no_xml}) {
197          print $out "Content-Type: text/plain";
198        } else {
199          print $out "Content-Type: $mt";
200        }
201    } else {    } else {
202      print "Content-Type: $mt";      print $out "Content-Type: $mt";
203    }    }
204    if ($charset) {    if ($charset) {
205      if ($self->{wiki}->{var}->{client}->{user_agent_name}      if ($dg->{media_type_no_parameter}) {
206          =~ m#Mozilla/[12]\.#) {        
207        print qq(; charset="@{[{qw/euc-jp x-euc-jp shift_jis x-sjis/}      } elsif ($dg->{charset_name_with_x}) {
208                               ->{$charset}        print $out qq(; charset="@{[{qw/euc-jp x-euc-jp shift_jis x-sjis/}
209                               || $charset]}");                                   ->{$charset} or $charset]}");
     } elsif ($self->{wiki}->{var}->{client}->{user_agent_name}  
              =~ m#Mozilla/0\.|Infomosaic#) {  
210      } else {      } else {
211        print qq(; charset=).$self->___quote_word ($charset);        print $out qq(; charset=).$self->___quote_word ($charset);
212      }      }
213    }    }
214    print $nl;    print $nl;
215        
216    for (join ', ', @{$self->{entity}->{language}||[]}) {    for (join ', ', @{$self->{entity}->{language}||[]}) {
217      print "Content-Language: $_$nl" if $_;      print $out "Content-Language: $_$nl" if $_;
218    }    }
219    print "Content-Length: @{[length $body]}$nl";    print $out "Content-Length: @{[length $body]}$nl";
220    print $nl;    print $out $nl;
221    print $body;    print $out $body;
222  }  }
223    
224  ## Note: CGI/1.1 draft 3 does not allow HTTP Header Fields  ## Note: CGI/1.1 draft 3 does not allow HTTP Header Fields
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.6
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24