/[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.3 by wakaba, Sat Dec 6 05:38:13 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),
# 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
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";    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};
# Line 179  sub output ($;%) { Line 186  sub output ($;%) {
186    ## TODO:    ## TODO:
187    $body = &main::code_convert (\$body, $self->{entity}->{charset});    $body = &main::code_convert (\$body, $self->{entity}->{charset});
188        
189    if (($mt eq 'application/rdf+xml')    if (substr ($mt, -4) eq '+xml') {
190        && (index ($self->{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: $mt";      print $out "Content-Type: $mt";
201    }    }
202    if ($charset) {    if ($charset) {
203      if ($self->{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                               ->{$charset}        print $out qq(; charset="@{[{qw/euc-jp x-euc-jp shift_jis x-sjis/}
207                               || $charset]}");                                   ->{$charset} or $charset]}");
     } elsif ($self->{wiki}->{var}->{client}->{user_agent_name}  
              =~ m#Mozilla/0\.|Infomosaic#) {  
208      } else {      } else {
209        print qq(; charset="$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 "Content-Length: @{[length $body]}$nl";    print $out "Content-Length: @{[length $body]}$nl";
218    print $nl;    print $out $nl;
219    print $body;    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  =item $self->exit
231    
232  Declares the instance ($self) no longer considered useful.  Declares the instance ($self) no longer considered useful.
# Line 227  sub DESTROY ($) { Line 246  sub DESTROY ($) {
246    $self->exit unless $self->{exited};    $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}  =item $self->{entity}->{charset}
260  =item $self->{entity}->{language} = [...]  =item $self->{entity}->{language} = [...]
261  =item $self->{entity}->{media_type}  =item $self->{entity}->{media_type}
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.5
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24