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

my %Status = (
  200 => q(OK),
  301 => q(Permanently Redirect),
  302 => q(Found),
  303 => q(See Other),
  307 => q(Temporary Redirect),
  401 => q(Authorization Required),
  403 => q(Forbidden),
  404 => q(Not Found),
  500 => q(Internal Server Error),
  503 => q(Service Temporary Unavailable),
);

=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} = $opt{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_uri ($%) {
  
}

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;
  binmode STDOUT;
  $| = 1;
  
  my $status = qq(@{[$self->{status_code}||200]} @{[$self->{status_phrase}||$Status{$self->{status_code}||200}]});
  if ($opt{output} eq 'http-cgi') {
    $nl = "\n";
    print "Status: $status$nl";
  } else {
    $nl = "\x0D\x0A";
    print "$status 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 $body = '' . $self->{entity}->{body};
  ## TODO:
  $body = &main::code_convert (\$body, $self->{entity}->{charset});
  
  if (($self->{entity}->{media_type} eq 'application/rdf+xml')
      && (index ($self->{view}->{wiki}->{var}->{client}->{user_agent_name},
                 'Gecko') > -1)) {
    print "Content-Type: application/xml";
  } else {
    print "Content-Type: $self->{entity}->{media_type}";
  }
  if ($self->{entity}->{charset}) {
    if ($self->{view}->{wiki}->{var}->{client}->{user_agent_name}
        =~ m#Mozilla/[12]\.#) {
      print qq(; charset="@{[{qw/euc-jp x-euc-jp shift_jis x-sjis/}
                             ->{$self->{entity}->{charset}}
                             || $self->{entity}->{charset}]}");
    } elsif ($self->{view}->{wiki}->{var}->{client}->{user_agent_name}
             =~ m#Mozilla/0\.|Infomosaic#) {
    } else {
      print qq(; charset="$self->{entity}->{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 <[email protected]>

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

=cut

1; # $Date: 2003/04/29 10:36:17 $
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			our $VERSION = do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17
18			my %Status = (
19			200 => q(OK),
20			301 => q(Permanently Redirect),
21			302 => q(Found),
22			303 => q(See Other),
23			307 => q(Temporary Redirect),
24			401 => q(Authorization Required),
25			403 => q(Forbidden),
26			404 => q(Not Found),
27			500 => q(Internal Server Error),
28			503 => q(Service Temporary Unavailable),
29			);
30
31			=head1 METHODS
32
33			=over 4
34
35			=item $http = SuikaWiki::Output::HTTP->new
36
37			Constructs new instance of HTTP output implementation
38
39			=cut
40
41			sub new ($;%) {
42			my $self = bless {header_field => [],
43			negotiate_header_field => {Negotiate => 1},
44			entity => {language => [],
45			media_type => 'application/octet-stream'},
46			}, shift;
47			my %opt = @_;
48			$self->{wiki} = $opt{wiki};
49			$self->{view} = $opt{view};
50			$self->{viewobj} = $opt{viewobj};
51			$self;
52			}
53
54			sub add_header_field ($$$;%) {
55			my ($self, $name => $body, %opt) = @_;
56			push @{$self->{header_field}}, {name => $name, body => $body};
57			}
58
59			sub add_negotiate_header_field ($$) {
60			my ($self, $name) = @_;
61			$self->{negotiate_header_field}->{$name} = 1;
62			}
63
64			sub set_expires ($%) {
65			my ($self, %opt) = @_;
66			if ($opt{time}) {
67			## TODO: use rfc1123-time
68			push @{$self->{header_field}}, {name => 'Expires',
69			body => scalar gmtime $opt{time}};
70			} elsif (defined $opt{delta}) {
71			$self->{expires_delta} = $opt{delta} + 0;
72			}
73			}
74
75			sub set_redirect_uri ($%) {
76
77			}
78
79			sub set_last_modified ($%) {
80			my ($self, %opt) = @_;
81			$self->{lastmodified_time} = $opt{time};
82			}
83
84			sub append_to_body ($$) {
85			my ($self, $s) = @_;
86			$self->{entity}->{body} .= $s;
87			}
88
89			sub output ($;%) {
90			my ($self, %opt) = @_;
91			my $nl;
92			binmode STDOUT;
93			$\| = 1;
94
95			my $status = qq(@{[$self->{status_code}\|\|200]} @{[$self->{status_phrase}\|\|$Status{$self->{status_code}\|\|200}]});
96			if ($opt{output} eq 'http-cgi') {
97			$nl = "\n";
98			print "Status: $status$nl";
99			} else {
100			$nl = "\x0D\x0A";
101			print "$status HTTP/1.1$nl";
102			}
103
104			for (@{$self->{header_field}}) {
105			print "$_->{name}: $_->{body}$nl";
106			}
107
108			my $time = time;
109			print "Date: @{[scalar gmtime $time]}$nl";
110			if (defined $self->{expires_delta}) {
111			print "Expires: @{[scalar gmtime ($time + $self->{expires_delta})]}$nl";
112			}
113			if (defined $self->{lastmodified_time}) {
114			print "Last-Modified: @{[scalar gmtime $self->{lastmodified_time}]}$nl";
115			} else {
116			print "Last-Modified: @{[scalar gmtime $time]}$nl";
117			}
118			print "Vary: ".join (', ', keys %{$self->{negotiate_header_field}})."$nl";
119
120			my $body = '' . $self->{entity}->{body};
121			## TODO:
122			$body = &main::code_convert (\$body, $self->{entity}->{charset});
123
124			if (($self->{entity}->{media_type} eq 'application/rdf+xml')
125			&& (index ($self->{view}->{wiki}->{var}->{client}->{user_agent_name},
126			'Gecko') > -1)) {
127			print "Content-Type: application/xml";
128			} else {
129			print "Content-Type: $self->{entity}->{media_type}";
130			}
131			if ($self->{entity}->{charset}) {
132			if ($self->{view}->{wiki}->{var}->{client}->{user_agent_name}
133			=~ m#Mozilla/[12]\.#) {
134			print qq(; charset="@{[{qw/euc-jp x-euc-jp shift_jis x-sjis/}
135			->{$self->{entity}->{charset}}
136			\|\| $self->{entity}->{charset}]}");
137			} elsif ($self->{view}->{wiki}->{var}->{client}->{user_agent_name}
138			=~ m#Mozilla/0\.\|Infomosaic#) {
139			} else {
140			print qq(; charset="$self->{entity}->{charset}");
141			}
142			}
143			print $nl;
144
145			for (join ', ', @{$self->{entity}->{language}\|\|[]}) {
146			print "Content-Language: $_$nl" if $_;
147			}
148			print "Content-Length: @{[length $body]}$nl";
149			print $nl;
150			print $body;
151			}
152
153			=item $self->{entity}->{charset}
154			=item $self->{entity}->{language} = [...]
155			=item $self->{entity}->{media_type}
156
157			=back
158
159			=head1 TODO
160
161			Use manakai.
162
163			=head1 LICENSE
164
165			Copyright 2003 Wakaba <[email protected]>
166
167			This program is free software; you can redistribute it and/or
168			modify it under the same terms as Perl itself.
169
170			=cut
171
172			1; # $Date: 2003/04/29 10:36:17 $