The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

LBROCARD / OpenFrame-Segment-Apache2-1.00 / lib / OpenFrame / Segment / Apache2 / Request.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
—
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154

              
package OpenFrame::Segment::Apache2::Request;
use strict;
use warnings;
use Apache2;
use Apache::Const;
use Apache::URI;
use CGI::Cookie;
use OpenFrame::Argument::Blob;
use OpenFrame::Object;
use OpenFrame::Cookies;
use OpenFrame::Request;
use OpenFrame::Segment::HTTP::Response;
use Pipeline::Segment;
use Scalar::Util qw ( blessed );
use URI;
our $VERSION = '1.02';
use base qw(Pipeline::Segment OpenFrame::Object);
sub init {
  my $self = shift;
  $self->emit("initialising");
  $self->SUPER::init( @_ );
}
sub dispatch {
  my $self  = shift;
  my $store = shift->store();
  $self->emit("being dispatched");
  my $r = $store->get('Apache::RequestRec');
  my ($ofr, $cookies) = $self->req2ofr($r);
  $self->emit("uri is " . $ofr->uri);
  $self->emit("dispatched and responding");
  return ($ofr, $cookies, OpenFrame::Segment::HTTP::Response->new());
}
##
## turns an Apache::Request object into an OpenFrame::Request object
##
sub req2ofr {
  my $self = shift;
  my $r    = shift;
  my $args = $self->req2args($r);
  my $ctin = $self->req2ctin($r);
  # hmmm, unfortunately Apache doesn't support $r->scheme so
  # we have to use Apache::URI
#  my $uri = URI->new(Apache::URI->parse_uri($r)->unparse);
  my $uri = URI->new($r->uri); # for now!
  my $ofr  = OpenFrame::Request->new()
                               ->arguments($args)
                               ->uri($uri);
  return ($ofr,$ctin);
}
sub req2ctin {
  my($self, $r) = @_;
  my $cookietin = OpenFrame::Cookies->new();
  my %cookies = CGI::Cookie->parse($r->headers_in->{Cookie});
  foreach my $key (keys %cookies) {
    $cookietin->set($key, $cookies{$key}->value);
  }
  return $cookietin;
}
sub req2args {
  my($self, $r) = @_;
  my @args = map {
    tr/+/ /;
    s/%([0-9a-fA-F]{2})/pack("C",hex($1))/ge;
    $_;
  } split /[=&;]/, $r->args, -1;
  my %args = @args;
  return \%args;
warn join(", ", @args);
#  my %args;
#  my $args = {
#              map {
#                   my $return;
#                   my @results = $ar->param($_);
#                   if (scalar(@results) > 1) {
#                     $return = [@results];
#                   } else {
#                     $return = $results[0];
#                   }
#                   ($_, $return)
#                  } @args
#            };
# DON'T DO UPLOADS YET!
#
#  foreach my $upload ( $ar->upload ) {
#    my $name = $upload->name;
#    my $filename = $upload->filename;
#    my $fh = $upload->fh;
#    my $blob = OpenFrame::Argument::Blob->new();
#    $blob->name($name);
#    $blob->filehandle($fh);
#    $blob->filename($filename) if $filename;
#    $args->{$name} = $blob;
#  }
  return {};
}
1;
__END__
=head1 NAME
OpenFrame::Segment::Apache::Request - Apache request segment
=head1 SYNOPSIS
  my $request = OpenFrame::Segment::Apache::Request->new();
  my $pipeline = Pipeline->new();
  $pipeline->add_segment($request);
  # add more segments here
=head1 DESCRIPTION
The OpenFrame::Segment::Apache::Request slot distribution provides a
segment for OpenFrame 3 that converts from Apache requests to
OpenFrame::Request objects. It should be the first segment in the
pipeline.
=head1 AUTHOR
Leon Brocard <acme@astray.com>
=head1 COPYRIGHT
Copyright 2002 Fotango Ltd.
Licensed under the same terms as Perl itself.
=cut