1# ======================================================================
2#
3# Copyright (C) 2000-2004 Paul Kulchenko (paulclinger@yahoo.com)
4# SOAP::Lite is free software; you can redistribute it
5# and/or modify it under the same terms as Perl itself.
6#
7# $Id: HTTP2.pm,v 1.3 2006/08/02 15:55:38 rkobes Exp $
8#
9# ======================================================================
10
11package SOAP::Transport::HTTP2;
12
13use strict;
14use vars qw($VERSION @ISA);
15#$VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name:  $ =~ /-(\d+)_([\d_]+)/);
16$VERSION = 0.73;
17
18use SOAP::Lite;
19use SOAP::Transport::HTTP;
20
21@ISA = qw(SOAP::Transport::HTTP);
22
23# ======================================================================
24
25package SOAP::Transport::HTTP2::Client;
26
27use vars qw(@ISA);
28@ISA = qw(SOAP::Transport::HTTP::Client);
29
30# ======================================================================
31
32package SOAP::Transport::HTTP2::Server;
33
34use vars qw(@ISA);
35@ISA = qw(SOAP::Transport::HTTP::Server);
36
37# ======================================================================
38
39package SOAP::Transport::HTTP2::CGI;
40
41use vars qw(@ISA);
42@ISA = qw(SOAP::Transport::HTTP::CGI);
43
44# ======================================================================
45
46package SOAP::Transport::HTTP2::Daemon;
47
48use vars qw(@ISA);
49@ISA = qw(SOAP::Transport::HTTP::Daemon);
50
51# ======================================================================
52
53package SOAP::Transport::HTTP2::Apache;
54
55use vars qw(@ISA);
56@ISA = qw(SOAP::Transport::HTTP::Server);
57
58sub DESTROY { SOAP::Trace::objects('()') }
59
60sub new {
61  my $self = shift;
62  unless (ref $self) {
63    my $class = ref($self) || $self;
64    $self = $class->SUPER::new(@_);
65    SOAP::Trace::objects('()');
66  }
67 MOD_PERL: {
68    ( (exists $ENV{MOD_PERL_API_VERSION}) &&
69      ($ENV{MOD_PERL_API_VERSION} == 2) ) and do {
70      require Apache2::RequestRec;
71      require Apache2::RequestUtil;
72      require Apache2::RequestIO;
73      require Apache2::Const;
74      require APR::Table;
75      Apache2::Const->import(-compile => 'OK');
76      $self->{'MOD_PERL_VERSION'} = 2;
77      last MOD_PERL;
78    };
79    (eval { require Apache;} ) and do {
80       require Apache::Constants;
81       Apache::Constants->import('OK');
82       $self->{'MOD_PERL_VERSION'} = 1;
83       last MOD_PERL;
84     };
85    die "Unsupported version of mod_perl";
86  }
87  return $self;
88}
89
90sub handler {
91  my $self = shift->new;
92  my $r = shift;
93  unless ($r) {
94    $r = ($self->{'MOD_PERL_VERSION'} == 1) ?
95      Apache->request : Apache2::RequestUtil->request();
96  }
97
98  my $cl = ($self->{'MOD_PERL_VERSION'} == 1) ?
99    $r->header_in('Content-length') : $r->headers_in->{'Content-length'};
100  $self->request(HTTP::Request->new(
101    $r->method() => $r->uri,
102    HTTP::Headers->new($r->headers_in),
103    do { my ($c,$buf); while ($r->read($buf,$cl)) { $c.=$buf; } $c; }
104  ));
105  $self->SUPER::handle;
106
107  # we will specify status manually for Apache, because
108  # if we do it as it has to be done, returning SERVER_ERROR,
109  # Apache will modify our content_type to 'text/html; ....'
110  # which is not what we want.
111  # will emulate normal response, but with custom status code
112  # which could also be 500.
113  if ($self->{'MOD_PERL_VERSION'} == 1 ) {
114    $self->response->headers->scan(sub { $r->header_out(@_) });
115    $r->send_http_header(join '; ', $self->response->content_type);
116    $r->print($self->response->content);
117    return &Apache::Constants::OK;
118  }
119  else {
120    $self->response->headers->scan(sub {
121                                     my %h = @_;
122                                     for (keys %h) {
123                                       $r->headers_out->{$_} = $h{$_};
124                                     }
125                                   });
126    $r->content_type(join '; ', $self->response->content_type);
127    $r->print($self->response->content);
128    return &Apache2::Const::OK;
129  }
130}
131
132sub configure {
133  my $self = shift->new;
134  my $config = shift->dir_config;
135  foreach (%$config) {
136    $config->{$_} =~ /=>/
137      ? $self->$_({split /\s*(?:=>|,)\s*/, $config->{$_}})
138      : ref $self->$_() ? () # hm, nothing can be done here
139                        : $self->$_(split /\s+|\s*,\s*/, $config->{$_})
140      if $self->can($_);
141  }
142  $self;
143}
144
145{ sub handle; *handle = \&handler } # just create alias
146
147# ======================================================================
148#
149# Copyright (C) 2001 Single Source oy (marko.asplund@kronodoc.fi)
150# a FastCGI transport class for SOAP::Lite.
151#
152# ======================================================================
153
154package SOAP::Transport::HTTP2::FCGI;
155
156use vars qw(@ISA);
157@ISA = qw(SOAP::Transport::HTTP::FCGI);
158
159# ======================================================================
160
1611;
162