The Perl and Raku Conference 2025: Greenville, South Carolina - June 27-29 Learn more

WONKO / CGI-Application-Plugin-Apache-1.02 / lib / CGI / Application / Plugin / 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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
—
175
176
177
178
179
180

              
package CGI::Application::Plugin::Apache2::Request;
use strict;
use Apache2::Request;
our @ISA = qw(Apache2::Request);
use Apache2::Upload;
use Apache2::Cookie;
use Apache2::URI;
sub new {
    my ($class, @args) = @_;
    return bless {
        r             => Apache2::Request->new(@args),
        __cap_params  => {},
        __cap_deleted => 0,
    }, $class;
}
# we need to implement our own params because Apache2::Request no
# longer allows you to maniu
sub param {
    my ($self, @args) = @_;
     
    # if we don't have anything in %PARAMS, then populate it from args
    my %params = %{$self->{__cap_params}};
    unless( %params or $self->{__cap_deleted} ) {
        foreach my $k ($self->SUPER::param()) {
            my @values = $self->SUPER::param($k);
            $params{$k} = @values > 1 ? \@values : $values[0];
        }
        $self->{__cap_params} = \%params;
    }
     
    # if we just want the value of a param
    if(@args > 1) {
        $params{$args[0]} = $args[1];
        return $self->args->{$args[0]} = $args[1];
    } elsif( @args ) {
        my @result = ref $params{$args[0]} ? @{$params{$args[0]}} : $params{$args[0]};
        return wantarray ?  @result : $result[0];
    } else {
        return keys %params;
    }
}
=pod
=head1 NAME
CGI::Application::Plugin::Apache::Request
=head1 DESCRIPTION
This package is just a wrapper around L<Apache::Request> /
L<Apache2::Request> to add L<CGI.pm|CGI> compatible methods. The interface
and usage is exactly the same as L<CGI.pm|CGI> for the methods provided.
=over 8
=item delete()
=cut
sub delete {
    my ($self, @args) = @_;
    delete $self->{__cap_params}->{$_} foreach (@args);
    $self->{__cap_deleted} = 1;
}
=item delete_all()
=cut
sub delete_all {
    my $self = shift;
    $self->{__cap_params} = {};
    $self->{__cap_deleted} = 1;
}
=item cookie()
=cut
sub cookie {
    my ($self, @args) = @_;
    if($#args == 0) {
        # if we just have a name of a cookie then retrieve the value of the cookie
        my $cookies = Apache2::Cookie->fetch();
        if( $cookies && $cookies->{$args[0]} ) {
            return $cookies->{$args[0]}->value;
        } else {
            return;
        }
    } else {
        # else we have several values so try and create a new cookie
        return Apache2::Cookie->new($self, @args);
    }
}
=item Dump()
=cut
sub Dump {
    my $self = shift;
    my($param,$value,@result);
    return '<ul></ul>' unless $self->param;
    push(@result,"<ul>");
    foreach $param ($self->param) {
        my $name = $self->escapeHTML($param);
        push(@result,"<li><strong>$name</strong></li>");
        push(@result,"<ul>");
        foreach $value ($self->param($param)) {
            $value = $self->escapeHTML($value);
            push(@result,"<li>$value</li>");
        }
        push(@result,"</ul>");
    }
    push(@result,"</ul>");
    return join("\n",@result);
}
=item Vars()
=cut
sub Vars {
    my $self = shift;
    my %vars = %{$self->{__cap_params}};
    return wantarray ? %vars : \%vars;
}
=item escapeHTML()
=cut
sub escapeHTML {
    my ($self, $value) = @_;
    require HTML::GenerateUtil;
    $value = HTML::GenerateUtil::escape_html($value, 
        (
            $HTML::GenerateUtil::EH_LFTOBR 
            | $HTML::GenerateUtil::EH_SPTONBSP 
            | $HTML::GenerateUtil::EH_LEAVEKNOWN
        )
    ); 
    return $value;
}
=item upload()
=cut
sub upload {
    my ($self, $file) = @_;
    # if they want a specific one, then lets give them the file handle
    if( $file ) {
        my $upload = $self->SUPER::upload($file);
        if( $upload ) {
            return $upload->fh();
        } else {
            return;
        }
    # else they want them all
    } else {
        my @files = $self->SUPER::upload();
        @files = map { $self->SUPER::upload($_)->fh() } @files;
        return @files;
    }
}
1;
__END__
=item 
=back
Please see L<CGI::Application::Plugin::Apache> for more details.