CGI.pm 5.37 KB
Newer Older
1 2 3 4 5 6 7
## @file
# Base package for all Lemonldap::NG CGI
#
# @copy 2005, 2006, 2007, 2008, Xavier Guimard <x.guimard@free.fr>

## @class
# Base class for all Lemonldap::NG portal CGI
8
package Lemonldap::NG::Common::CGI;
9 10 11 12 13 14 15

use strict;

use MIME::Base64;
use Time::Local;
use CGI;

16
our $VERSION = '0.3';
17

18
use base qw(CGI);
19

20 21 22
sub soapTest {
    my $self = shift;
    my $soapFunctions = shift || $self->{SOAPFunctions};
23 24

    # If non form encoded datas are posted, we call SOAP Services
25
    if ( $ENV{HTTP_SOAPACTION} ) {
26
        my @func = ();
27 28
        foreach ( ref($soapFunctions) ? @$soapFunctions : split /\s+/, $soapFunctions ) {
            $_ = ref($self) . "::$_" unless (/::/);
29 30 31 32
            push @func, $_;
        }
        Lemonldap::NG::Common::CGI::SOAPServer->dispatch_to(@func)
          ->handle($self);
33 34 35
        exit;
    }
    return $self;
36 37 38
}

sub header_public {
39
    my $self     = shift;
40
    my $filename = shift;
41
    $filename ||= $ENV{SCRIPT_FILENAME};
42
    my @tmp  = stat($filename);
43
    my $date = $tmp[9];
44 45
    my $hd   = gmtime($date);
    $hd =~ s/^(\w+)\s+(\w+)\s+(\d+)\s+([\d:]+)\s+(\d+)$/$1, $3 $2 $5 $4 GMT/;
46
    my $year = $5;
47 48
    my $cm   = $2;

49
    # TODO: Remove TODO_ for stable releases
50
    if ( my $ref = $ENV{HTTP_IF_MODIFIED_SINCE} ) {
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73
        my %month = (
            jan => 0,
            feb => 1,
            mar => 2,
            apr => 3,
            may => 4,
            jun => 5,
            jul => 6,
            aug => 7,
            sep => 8,
            oct => 9,
            nov => 10,
            dec => 11
        );
        if ( $ref =~ /^\w+,\s+(\d+)\s+(\w+)\s+(\d+)\s+(\d+):(\d+):(\d+)/ ) {
            my $m = $month{ lc($2) };
            $year-- if ( $m > $month{ lc($cm) } );
            $ref = timegm( $6, $5, $4, $1, $m, $3 );
            if ( $ref == $date ) {
                print $self->SUPER::header( -status => '304 Not Modified', @_ );
                exit;
            }
        }
74
    }
75 76
    return $self->SUPER::header(
        '-Last-Modified' => $hd,
77
        '-Cache-Control' => 'public; must-revalidate; max-age=1800',
78 79
        @_
    );
80 81
}

82 83
sub abort {
    my $self = shift;
84
    my $cgi  = CGI->new;
85 86
    my ( $t1, $t2 ) = @_;
    $t2 ||= "See Apache's logs";
87 88 89
    print $cgi->header(
        -type    => 'text/html; charset=utf8',
    );
90 91 92 93 94 95
    print $cgi->start_html(
        -title    => $t1,
        -encoding => 'utf8',
    );
    print "<h1>$t1</h1>";
    print "<p>$t2</p>";
96
    print STDERR ( ref($self)|| $self ) . " error: $t1, $t2\n";
97 98 99
    exit;
}

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
package Lemonldap::NG::Common::CGI::SOAPServer;
use SOAP::Transport::HTTP;
use base 'SOAP::Transport::HTTP::Server';

sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;
    return $self if ref $self;

    my $class = ref($self) || $self;
    $self = $class->SUPER::new(@_);
    SOAP::Trace::objects('()');

    return $self;
}

sub handle {
    my $self = shift->new;
    my $cgi  = shift;

    my $content = $cgi->param('POSTDATA');
    my $length  = length($content);

    if ( !$length ) {
        $self->response( HTTP::Response->new(411) )    # LENGTH REQUIRED
    }
    elsif ( defined $SOAP::Constants::MAX_CONTENT_SIZE
        && $length > $SOAP::Constants::MAX_CONTENT_SIZE )
    {
        $self->response( HTTP::Response->new(413) )   # REQUEST ENTITY TOO LARGE
    }
    else {
        $self->request(
            HTTP::Request->new(
                'POST' => $ENV{'SCRIPT_NAME'},
                HTTP::Headers->new(
                    map {
                        (
                              /^HTTP_(.+)/i
                            ? ( $1 =~ m/SOAPACTION/ )
                                  ? ('SOAPAction')
                                  : ($1)
                            : $_
                          ) => $ENV{$_}
                      } keys %ENV
                ),
                $content,
            )
        );
        $self->SUPER::handle;
    }

    print $cgi->header(
        -status => $self->response->code . " "
          . HTTP::Status::status_message( $self->response->code ),
        -type           => $self->response->header('Content-Type'),
        -Content_Length => $self->response->header('Content-Length'),
        -SOAPServer     => 'Lemonldap::NG CGI',
    );
    print $self->response->content;
}

163 164 165 166 167 168
1;

__END__

=head1 NAME

169
Lemonldap::NG::Common::CGI - Simple module to extend L<CGI> to manage
170 171 172 173
HTTP "If-Modified-Since / 304 Not Modified" system.

=head1 SYNOPSIS

174
  use Lemonldap::NG::Common::CGI;
175
  
176
  my $cgi = Lemonldap::NG::Common::CGI->new();
177 178 179 180 181 182
  $cgi->header_public($ENV{SCRIPT_FILENAME});
  print "<html><head><title>Static page</title></head>";
  ...

=head1 DESCRIPTION

183
Lemonldap::NG::Common::CGI just add header_public subroutine to CGI module to
184 185 186 187 188 189 190 191 192 193 194 195 196
avoid printing HTML elements that can be cached.

=head1 METHODS

=head2 header_public

header_public works like header (see L<CGI>) but the first argument has to be
a filename: the last modify date of this file is used for reference.

=head2 EXPORT

=head1 SEE ALSO

197 198
L<Lemonldap::NG::Manager>, L<CGI>,
http://wiki.lemonldap.objectweb.org/xwiki/bin/view/NG/Presentation
199 200 201 202 203 204 205

=head1 AUTHOR

Xavier Guimard, E<lt>x.guimard@free.frE<gt>

=head1 COPYRIGHT AND LICENSE

206
Copyright (C) 2006-2007 by Xavier Guimard E<lt>x.guimard@free.frE<gt>
207 208 209 210 211 212

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.4 or,
at your option, any later version of Perl 5 you may have available.

=cut