## @file
# Base package for all Lemonldap::NG CGI
## @class
# Base class for all Lemonldap::NG CGI
package Lemonldap::NG::Common::CGI;
use strict;
use File::Basename;
use MIME::Base64;
use Time::Local;
use CGI;
use utf8;
use Encode;
use Net::CIDR::Lite;
#parameter syslog Indicates syslog facility for logging user actions
our $VERSION = '1.4.0';
our $_SUPER;
our @ISA;
BEGIN {
if ( exists $ENV{MOD_PERL} ) {
if ( $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2 ) {
eval 'use constant MP => 2;';
}
else {
eval 'use constant MP => 1;';
}
}
else {
eval 'use constant MP => 0;';
}
$_SUPER = 'CGI';
@ISA = ('CGI');
}
sub import {
my $pkg = shift;
if ( $pkg eq __PACKAGE__ and @_ and $_[0] eq "fastcgi" ) {
eval 'use CGI::Fast';
die($@) if ($@);
unshift @ISA, 'CGI::Fast';
$_SUPER = 'CGI::Fast';
}
}
## @cmethod Lemonldap::NG::Common::CGI new(@p)
# Constructor: launch CGI::new() then secure parameters since CGI store them at
# the root of the object.
# @param p arguments for CGI::new()
# @return new Lemonldap::NG::Common::CGI object
sub new {
my $class = shift;
my $self = $_SUPER->new(@_) or return undef;
$self->{_prm} = {};
my @tmp = $self->param();
foreach (@tmp) {
$self->{_prm}->{$_} = $self->param($_);
$self->delete($_);
}
$self->{lang} = extract_lang();
bless $self, $class;
return $self;
}
## @method scalar param(string s, scalar newValue)
# Return the wanted parameter issued of GET or POST request. If $s is not set,
# return the list of parameters names
# @param $s name of the parameter
# @param $newValue if set, the parameter will be set to his value
# @return datas passed by GET or POST method
sub param {
my ( $self, $p, $v ) = @_;
$self->{_prm}->{$p} = $v if ($v);
unless ( defined $p ) {
return keys %{ $self->{_prm} };
}
return $self->{_prm}->{$p};
}
## @method scalar rparam(string s)
# Return a reference to a parameter
# @param $s name of the parameter
# @return ref to parameter data
sub rparam {
my ( $self, $p ) = @_;
return $self->{_prm}->{$p} ? \$self->{_prm}->{$p} : undef;
}
## @method void lmLog(string mess, string level)
# Log subroutine. Use Apache::Log in ModPerl::Registry context else simply
# print on STDERR non debug messages.
# @param $mess Text to log
# @param $level Level (debug|info|notice|error)
sub lmLog {
my ( $self, $mess, $level ) = @_;
my $call;
if ( $level eq 'debug' ) {
$mess = ( ref($self) ? ref($self) : $self ) . ": $mess";
}
else {
my @tmp = caller();
$call = "$tmp[1] $tmp[2]:";
}
if ( $self->r and MP() ) {
$self->abort( "Level is required",
'the parameter "level" is required when lmLog() is used' )
unless ($level);
if ( MP() == 2 ) {
require Apache2::Log;
Apache2::ServerRec->log->debug($call) if ($call);
Apache2::ServerRec->log->$level($mess);
}
else {
Apache->server->log->debug($call) if ($call);
Apache->server->log->$level($mess);
}
}
else {
$self->{hideLogLevels} = 'debug|info'
unless defined( $self->{hideLogLevels} );
my $re = qr/^(?:$self->{hideLogLevels})$/;
print STDERR "$call\n" if ( $call and 'debug' !~ $re );
print STDERR "[$level] $mess\n" unless ( $level =~ $re );
}
}
## @method void setApacheUser(string user)
# Set user for Apache logs in ModPerl::Registry context. Does nothing else.
# @param $user data to set as user in Apache logs
sub setApacheUser {
my ( $self, $user ) = @_;
if ( $self->r and MP() ) {
$self->lmLog( "Inform Apache about the user connected", 'debug' );
if ( MP() == 2 ) {
require Apache2::Connection;
$self->r->user($user);
}
else {
$self->r->connection->user($user);
}
}
$ENV{REMOTE_USER} = $user;
}
##@method string getApacheHtdocsPath()
# Return absolute path to the htdocs directory where the current script is
# @return path string
sub getApacheHtdocsPath {
return dirname( $ENV{SCRIPT_FILENAME} || $0 );
}
## @method void soapTest(string soapFunctions, object obj)
# Check if request is a SOAP request. If it is, launch
# Lemonldap::NG::Common::CGI::SOAPServer and exit. Else simply return.
# @param $soapFunctions list of authorized functions.
# @param $obj optional object that will receive SOAP requests
sub soapTest {
my ( $self, $soapFunctions, $obj ) = @_;
# If non form encoded datas are posted, we call SOAP Services
if ( $ENV{HTTP_SOAPACTION} ) {
require
Lemonldap::NG::Common::CGI::SOAPServer; #link protected dispatcher
require
Lemonldap::NG::Common::CGI::SOAPService; #link protected soapService
my @func = (
ref($soapFunctions) ? @$soapFunctions : split /\s+/,
$soapFunctions
);
my $dispatcher =
Lemonldap::NG::Common::CGI::SOAPService->new( $obj || $self, @func );
Lemonldap::NG::Common::CGI::SOAPServer->dispatch_to($dispatcher)
->handle($self);
$self->quit();
}
}
## @method string header_public(string filename)
# Implements the "304 Not Modified" HTTP mechanism.
# If HTTP request contains an "If-Modified-Since" header and if
# $filename was not modified since, prints the "304 Not Modified" response and
# exit. Else, launch CGI::header() with "Cache-Control" and "Last-Modified"
# headers.
# @param $filename Optional name of the reference file. Default
# $ENV{SCRIPT_FILENAME}.
# @return Common Gateway Interface standard response header
sub header_public {
my $self = shift;
my $filename = shift;
$filename ||= $ENV{SCRIPT_FILENAME};
my @tmp = stat($filename);
my $date = $tmp[9];
my $hd = gmtime($date);
$hd =~ s/^(\w+)\s+(\w+)\s+(\d+)\s+([\d:]+)\s+(\d+)$/$1, $3 $2 $5 $4 GMT/;
my $year = $5;
my $cm = $2;
# TODO: Remove TODO_ for stable releases
if ( my $ref = $ENV{HTTP_IF_MODIFIED_SINCE} ) {
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', @_ );
$self->quit();
}
}
}
return $self->SUPER::header(
'-Last-Modified' => $hd,
'-Cache-Control' => 'public; must-revalidate; max-age=1800',
@_
);
}
## @method void abort(string title, string text)
# Display an error message and exit.
# Used instead of die() in Lemonldap::NG CGIs.
# @param title Title of the error message
# @param text Optional text. Default: "See Apache's logs"
sub abort {
my $self = shift;
my $cgi = CGI->new();
my ( $t1, $t2 ) = @_;
# Default message
$t2 ||= "See Apache's logs";
# Change \n into
for HTML
my $t2html = $t2;
$t2html =~ s#\n#
#g;
print $cgi->header( -type => 'text/html; charset=utf-8', );
print $cgi->start_html(
-title => $t1,
-encoding => 'utf8',
-style => {
-code => '
body{
background:#000;
color:#fff;
padding:10px 50px;
font-family:sans-serif;
}
a {
text-decoration:none;
color:#fff;
}
'
},
);
print "
$t2html
"; print '