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