Remove old CGI files (#595)
This commit is contained in:
Xavier Guimard
parent
6cccc434e1
commit
9e12c94234
|
|
@ -9,7 +9,6 @@ lib/Lemonldap/NG/Common/Apache/Session/Serialize/JSON.pm
|
|||
lib/Lemonldap/NG/Common/Apache/Session/SOAP.pm
|
||||
lib/Lemonldap/NG/Common/Apache/Session/Store.pm
|
||||
lib/Lemonldap/NG/Common/Captcha.pm
|
||||
lib/Lemonldap/NG/Common/CGI.pm
|
||||
lib/Lemonldap/NG/Common/Cli.pm
|
||||
lib/Lemonldap/NG/Common/Combination/Parser.pm
|
||||
lib/Lemonldap/NG/Common/Conf.pm
|
||||
|
|
@ -65,7 +64,6 @@ t/02-Common-Conf-File.t
|
|||
t/03-Common-Conf-CDBI.t
|
||||
t/03-Common-Conf-RDBI.t
|
||||
t/05-Common-Conf-LDAP.t
|
||||
t/20-Common-CGI.t
|
||||
t/30-Common-Safelib.t
|
||||
t/35-Common-Crypto.t
|
||||
t/36-Common-Regexp.t
|
||||
|
|
|
|||
|
|
@ -1,543 +0,0 @@
|
|||
## @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 = '2.0.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 <br /> for HTML
|
||||
my $t2html = $t2;
|
||||
$t2html =~ s#\n#<br />#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 "<h1>$t1</h1><p>$t2html</p>";
|
||||
print
|
||||
'<center><a href="http://lemonldap-ng.org">LemonLDAP::NG</a></center>';
|
||||
print STDERR ( ref($self) || $self ) . " error: $t1, $t2\n";
|
||||
print $cgi->end_html();
|
||||
$self->quit();
|
||||
}
|
||||
|
||||
##@method private void startSyslog()
|
||||
# Open syslog connection.
|
||||
sub startSyslog {
|
||||
my $self = shift;
|
||||
return if ( $self->{_syslog} );
|
||||
eval {
|
||||
require Sys::Syslog;
|
||||
Sys::Syslog->import(':standard');
|
||||
openlog( 'lemonldap-ng', 'ndelay,pid', $self->{syslog} );
|
||||
};
|
||||
$self->abort( "Unable to use syslog", $@ ) if ($@);
|
||||
$self->{_syslog} = 1;
|
||||
}
|
||||
|
||||
##@method void userLog(string mess, string level)
|
||||
# Log user actions on Apache logs or syslog.
|
||||
# @param $mess string to log
|
||||
# @param $level level of log message
|
||||
sub userLog {
|
||||
my ( $self, $mess, $level ) = @_;
|
||||
if ( $self->{syslog} ) {
|
||||
$self->startSyslog();
|
||||
$level =~ s/^warn$/warning/;
|
||||
syslog( $level || 'notice', $mess );
|
||||
}
|
||||
else {
|
||||
$self->lmLog( $mess, $level );
|
||||
}
|
||||
}
|
||||
|
||||
##@method void userInfo(string mess)
|
||||
# Log non important user actions. Alias for userLog() with facility "info".
|
||||
# @param $mess string to log
|
||||
sub userInfo {
|
||||
my ( $self, $mess ) = @_;
|
||||
$mess = "Lemonldap::NG : $mess (" . $self->ipAddr . ")";
|
||||
$self->userLog( $mess, 'info' );
|
||||
}
|
||||
|
||||
##@method void userNotice(string mess)
|
||||
# Log user actions like access and logout. Alias for userLog() with facility
|
||||
# "notice".
|
||||
# @param $mess string to log
|
||||
sub userNotice {
|
||||
my ( $self, $mess ) = @_;
|
||||
$mess = "Lemonldap::NG : $mess (" . $self->ipAddr . ")";
|
||||
$self->userLog( $mess, 'notice' );
|
||||
}
|
||||
|
||||
##@method void userError(string mess)
|
||||
# Log user errors like "bad password". Alias for userLog() with facility
|
||||
# "warn".
|
||||
# @param $mess string to log
|
||||
sub userError {
|
||||
my ( $self, $mess ) = @_;
|
||||
$mess = "Lemonldap::NG : $mess (" . $self->ipAddr . ")";
|
||||
$self->userLog( $mess, 'warn' );
|
||||
}
|
||||
|
||||
## @method protected scalar _sub(string sub, array p)
|
||||
# Launch $self->{$sub} if defined, else launch $self->$sub.
|
||||
# @param $sub name of the sub to launch
|
||||
# @param @p parameters for the sub
|
||||
sub _sub {
|
||||
my ( $self, $sub, @p ) = @_;
|
||||
if ( $self->{$sub} ) {
|
||||
$self->lmLog( "processing to custom sub $sub", 'debug' );
|
||||
return &{ $self->{$sub} }( $self, @p );
|
||||
}
|
||||
else {
|
||||
$self->lmLog( "processing to sub $sub", 'debug' );
|
||||
return $self->$sub(@p);
|
||||
}
|
||||
}
|
||||
|
||||
##@method string extract_lang
|
||||
#@return array of user's preferred languages (two letters)
|
||||
sub extract_lang {
|
||||
my $self = shift;
|
||||
|
||||
my @langs = split /,\s*/, ( shift || $ENV{HTTP_ACCEPT_LANGUAGE} || "" );
|
||||
my @res = ();
|
||||
|
||||
foreach (@langs) {
|
||||
|
||||
# Languages are supposed to be sorted by preference
|
||||
my $lang = ( split /;/ )[0];
|
||||
|
||||
# Take first part of lang code (part before -)
|
||||
$lang = ( split /-/, $lang )[0];
|
||||
|
||||
# Go to next if lang was already added
|
||||
next if grep( /\Q$lang\E/, @res );
|
||||
|
||||
# Store lang only if size is 2 characters
|
||||
push @res, $lang if ( length($lang) == 2 );
|
||||
}
|
||||
|
||||
return \@res;
|
||||
}
|
||||
|
||||
##@method void translate_template(string text_ref, string lang)
|
||||
# translate_template is used as an HTML::Template filter to tranlate strings in
|
||||
# the wanted language
|
||||
#@param text_ref reference to the string to translate
|
||||
#@param lang optionnal language wanted. Falls to browser language instead.
|
||||
#@return
|
||||
sub translate_template {
|
||||
my $self = shift;
|
||||
my $text_ref = shift;
|
||||
|
||||
# Decode UTF-8
|
||||
utf8::decode($$text_ref) unless ( $ENV{FCGI_ROLE} );
|
||||
|
||||
# Test if a translation is available for the selected language
|
||||
# If not available, return the first translated string
|
||||
# <lang en="Please enter your credentials" fr="Merci de vous autentifier"/>
|
||||
foreach ( @{ $self->{lang} } ) {
|
||||
if ( $$text_ref =~ m/$_=\"(.*?)\"/ ) {
|
||||
$$text_ref =~ s/<lang.*$_=\"(.*?)\".*?\/>/$1/gx;
|
||||
return;
|
||||
}
|
||||
}
|
||||
$$text_ref =~ s/<lang\s+\w+=\"(.*?)\".*?\/>/$1/gx;
|
||||
}
|
||||
|
||||
##@method void session_template(string text_ref)
|
||||
# session_template is used as an HTML::Template filter to replace session info
|
||||
# by their value
|
||||
#@param text_ref reference to the string to translate
|
||||
#@return
|
||||
sub session_template {
|
||||
my $self = shift;
|
||||
my $text_ref = shift;
|
||||
|
||||
# Replace session information
|
||||
$$text_ref =~ s/\$(\w+)/decode("utf8",$self->{sessionInfo}->{$1})/ge;
|
||||
}
|
||||
|
||||
## @method private void quit()
|
||||
# Simply exit.
|
||||
sub quit {
|
||||
my $self = shift;
|
||||
if ( $_SUPER eq 'CGI::Fast' ) {
|
||||
next LMAUTH;
|
||||
}
|
||||
else {
|
||||
exit;
|
||||
}
|
||||
}
|
||||
|
||||
##@method string ipAddr()
|
||||
# Retrieve client IP address from remote address or X-FORWARDED-FOR header
|
||||
#@return client IP
|
||||
sub ipAddr {
|
||||
my $self = shift;
|
||||
|
||||
unless ( $self->{ipAddr} ) {
|
||||
$self->{ipAddr} = $ENV{REMOTE_ADDR};
|
||||
if ( my $xheader = $ENV{HTTP_X_FORWARDED_FOR} ) {
|
||||
if ( $self->{trustedProxies} =~ /\*/
|
||||
or $self->{useXForwardedForIP} )
|
||||
{
|
||||
$self->{ipAddr} = $1 if ( $xheader =~ /^([^,]*)/ );
|
||||
}
|
||||
elsif ( $self->{trustedProxies} ) {
|
||||
my $localIP =
|
||||
Net::CIDR::Lite->new("127.0.0.0/8"); # TODO: add IPv6 local IP
|
||||
my $trustedIP =
|
||||
Net::CIDR::Lite->new( split /\s+/, $self->{trustedProxies} );
|
||||
while (
|
||||
(
|
||||
$localIP->find( $self->{ipAddr} )
|
||||
or $trustedIP->find( $self->{ipAddr} )
|
||||
)
|
||||
and $xheader =~ s/[,\s]*([^,\s]+)$//
|
||||
)
|
||||
{
|
||||
|
||||
# because it is of no use to store a local IP as client IP
|
||||
$self->{ipAddr} = $1 unless ( $localIP->find($1) );
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return $self->{ipAddr};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
=encoding utf8
|
||||
|
||||
Lemonldap::NG::Common::CGI - Simple module to extend L<CGI>. DEPRECATED
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Lemonldap::NG::Common::CGI;
|
||||
|
||||
my $cgi = Lemonldap::NG::Common::CGI->new();
|
||||
$cgi->header_public($ENV{SCRIPT_FILENAME});
|
||||
print "<html><head><title>Static page</title></head>";
|
||||
...
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Lemonldap::NG::Common::CGI just add header_public subroutine to CGI module to
|
||||
avoid printing HTML elements that can be cached. It manage HTTP
|
||||
"If-Modified-Since / 304 Not Modified" system.
|
||||
|
||||
This module has been deprecated, now use FastCGI/PSGI packages.
|
||||
|
||||
=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.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<http://lemonldap-ng.org/>, L<Lemonldap::NG::Common::PSGI>,
|
||||
L<Lemonldap::NG::Common::PSGI::Router>, L<Lemonldap::NG::Handler::PSGI>,
|
||||
L<Lemonldap::NG::Handler::PSGI::Router>, L<Lemonldap::NG::Handler::PSGI::Server>,
|
||||
L<Lemonldap::NG::Handler::PSGI::Try>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over
|
||||
|
||||
=item LemonLDAP::NG team L<http://lemonldap-ng.org/team>
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUG REPORT
|
||||
|
||||
Use OW2 system to report bug or ask for features:
|
||||
L<http://jira.ow2.org>
|
||||
|
||||
=head1 DOWNLOAD
|
||||
|
||||
Lemonldap::NG is available at
|
||||
L<http://forge.objectweb.org/project/showfiles.php?group_id=274>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
See COPYING file for details.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 2, or (at your option)
|
||||
any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program. If not, see L<http://www.gnu.org/licenses/>.
|
||||
|
||||
=cut
|
||||
|
|
@ -1,116 +0,0 @@
|
|||
# Before `make install' is performed this script should be runnable with
|
||||
# `make test'. After `make install' it should work as `perl Lemonldap-NG-Manager.t'
|
||||
|
||||
#########################
|
||||
|
||||
# change 'tests => 1' to 'tests => last_test_to_print';
|
||||
package My::Portal;
|
||||
|
||||
use strict;
|
||||
use Test::More tests => 22;
|
||||
use_ok('Lemonldap::NG::Common::CGI');
|
||||
|
||||
#our @ISA = qw('Lemonldap::NG::Common::CGI');
|
||||
use base 'Lemonldap::NG::Common::CGI';
|
||||
|
||||
sub mySubtest {
|
||||
return 'OK1';
|
||||
}
|
||||
|
||||
sub abort {
|
||||
shift;
|
||||
$, = '';
|
||||
print STDERR @_;
|
||||
die 'abort has been called';
|
||||
}
|
||||
|
||||
sub quit {
|
||||
2;
|
||||
}
|
||||
|
||||
our $param;
|
||||
|
||||
sub param {
|
||||
return $param;
|
||||
}
|
||||
|
||||
our $buf;
|
||||
our $lastpos = 0;
|
||||
|
||||
sub diff {
|
||||
my $str = $buf;
|
||||
$str =~ s/^.{$lastpos}//s if ($lastpos);
|
||||
$str =~ s/\r//gs;
|
||||
$lastpos = length $buf;
|
||||
return $str;
|
||||
}
|
||||
|
||||
SKIP: {
|
||||
eval "use IO::String;";
|
||||
skip "IO::String not installed", 9 if ($@);
|
||||
tie *STDOUT, 'IO::String', $buf;
|
||||
|
||||
#########################
|
||||
|
||||
# Insert your test code below, the Test::More module is use()ed here so read
|
||||
# its man page ( perldoc Test::More ) for help writing this test script.
|
||||
|
||||
my $cgi;
|
||||
|
||||
$ENV{SCRIPT_NAME} = '/test.pl';
|
||||
$ENV{SCRIPT_FILENAME} = 't/20-Common-CGI.t';
|
||||
$ENV{REQUEST_METHOD} = 'GET';
|
||||
$ENV{REQUEST_URI} = '/';
|
||||
$ENV{QUERY_STRING} = '';
|
||||
|
||||
#$cgi = CGI->new;
|
||||
ok( ( $cgi = Lemonldap::NG::Common::CGI->new() ), 'New CGI' );
|
||||
bless $cgi, 'My::Portal';
|
||||
|
||||
# Test header_public
|
||||
ok( $buf = $cgi->header_public('t/20-Common-CGI.t'), 'header_public' );
|
||||
ok( $buf =~ /Cache-control: public; must-revalidate; max-age=\d+\r?\n/s,
|
||||
'Cache-Control' );
|
||||
ok( $buf =~ /Last-modified: /s, 'Last-Modified' );
|
||||
|
||||
# Test _sub mechanism
|
||||
ok( $cgi->_sub('mySubtest') eq 'OK1', '_sub mechanism 1' );
|
||||
$cgi->{mySubtest} = sub { return 'OK2' };
|
||||
ok( $cgi->_sub('mySubtest') eq 'OK2', '_sub mechanism 2' );
|
||||
|
||||
# Test extract_lang
|
||||
my $lang;
|
||||
ok( $lang = $cgi->extract_lang(),
|
||||
'extract_lang 0 with void "Accept-language"' );
|
||||
ok( scalar(@$lang) == 0, 'extract_lang 1 with void "Accept-language"' );
|
||||
|
||||
my $cgi2;
|
||||
$ENV{SCRIPT_NAME} = '/test.pl';
|
||||
$ENV{SCRIPT_FILENAME} = 't/20-Common-CGI.t';
|
||||
$ENV{REQUEST_METHOD} = 'GET';
|
||||
$ENV{REQUEST_URI} = '/';
|
||||
$ENV{QUERY_STRING} = '';
|
||||
$ENV{HTTP_ACCEPT_LANGUAGE} = 'fr,fr-fr;q=0.8,en-us;q=0.5,en;q=0.3';
|
||||
ok( ( $cgi2 = Lemonldap::NG::Common::CGI->new() ), 'New CGI' );
|
||||
ok( $lang = $cgi2->extract_lang(), 'extract_lang' );
|
||||
ok( $lang->[0] eq 'fr', 'extract_lang' );
|
||||
ok( $lang->[1] eq 'en', 'extract_lang' );
|
||||
ok( scalar(@$lang) == 2, 'extract_lang' );
|
||||
|
||||
# Extract lang Android (See #LEMONLDAP-530)
|
||||
my $cgi3;
|
||||
$ENV{HTTP_ACCEPT_LANGUAGE} = 'fr-FR, en-US';
|
||||
ok( ( $cgi3 = Lemonldap::NG::Common::CGI->new() ), 'New CGI' );
|
||||
ok( $lang = $cgi3->extract_lang(), 'extract_lang Android' );
|
||||
ok( $lang->[0] eq 'fr', 'extract_lang Android' );
|
||||
ok( $lang->[1] eq 'en', 'extract_lang Android' );
|
||||
ok( scalar(@$lang) == 2, 'extract_lang Android' );
|
||||
|
||||
# Extract lang with * value
|
||||
my $cgi4;
|
||||
$ENV{HTTP_ACCEPT_LANGUAGE} = "fr,en,*";
|
||||
ok( ( $cgi4 = Lemonldap::NG::Common::CGI->new() ), 'New CGI' );
|
||||
ok( $lang = $cgi4->extract_lang(), 'extract_lang with * value' );
|
||||
ok( scalar(@$lang) == 2, 'extract_lang with * value' );
|
||||
|
||||
}
|
||||
|
|
@ -5,10 +5,8 @@ example/scripts/purgeLocalCache
|
|||
example/scripts/purgeLocalCache.cron.d
|
||||
lib/Lemonldap/NG/Handler.pm
|
||||
lib/Lemonldap/NG/Handler/ApacheMP2.pm
|
||||
lib/Lemonldap/NG/Handler/API/CGI.pm
|
||||
lib/Lemonldap/NG/Handler/API/ExperimentalNginx.pm
|
||||
lib/Lemonldap/NG/Handler/AuthBasic.pm
|
||||
lib/Lemonldap/NG/Handler/CGI.pm
|
||||
lib/Lemonldap/NG/Handler/Lib/AuthBasic.pm
|
||||
lib/Lemonldap/NG/Handler/Main.pm
|
||||
lib/Lemonldap/NG/Handler/Main/Init.pm
|
||||
|
|
@ -37,7 +35,6 @@ t/05-Lemonldap-NG-Handler-Reload.t
|
|||
t/10-Lemonldap-NG-Handler-SharedConf.t
|
||||
t/12-Lemonldap-NG-Handler-Jail.t
|
||||
t/13-Lemonldap-NG-Handler-Fake-Safe.t
|
||||
t/30-Lemonldap-NG-Handler-CGI.t
|
||||
t/50-Lemonldap-NG-Handler-SecureToken.t
|
||||
t/51-Lemonldap-NG-Handler-Zimbra.t
|
||||
t/52-Lemonldap-NG-Handler-AuthBasic.t
|
||||
|
|
|
|||
|
|
@ -1,188 +0,0 @@
|
|||
package Lemonldap::NG::Handler::API::CGI;
|
||||
|
||||
our $VERSION = '2.0.0';
|
||||
|
||||
# Specific modules and constants for Test or CGI
|
||||
use constant FORBIDDEN => 403;
|
||||
use constant HTTP_UNAUTHORIZED => 401;
|
||||
use constant REDIRECT => 302;
|
||||
use constant OK => 0;
|
||||
use constant DECLINED => 0;
|
||||
use constant DONE => 0;
|
||||
use constant SERVER_ERROR => 500;
|
||||
use constant AUTH_REQUIRED => 401;
|
||||
use constant MAINTENANCE => 503;
|
||||
|
||||
# Log level, since it can't be set in server config
|
||||
# Default value 'notice' can be changed in lemonldap-ng.ini or in init args
|
||||
our $logLevel = "notice";
|
||||
|
||||
my $request; # object to store data about current request
|
||||
|
||||
## @method void setServerSignature(string sign)
|
||||
# modifies web server signature
|
||||
# @param $sign String to add to server signature
|
||||
sub setServerSignature {
|
||||
my ( $class, $sign ) = @_;
|
||||
$ENV{SERVER_SOFTWARE} .= " $sign";
|
||||
}
|
||||
|
||||
## @method void thread_share(string $variable)
|
||||
# share or not the variable (if authorized by specific module)
|
||||
# @param $variable the name of the variable to share
|
||||
sub thread_share {
|
||||
|
||||
# nothing to do in CGI
|
||||
}
|
||||
|
||||
sub newRequest {
|
||||
my ( $class, $r ) = @_;
|
||||
$request = $r;
|
||||
$Lemonldap::NG::API::mode = 'CGI';
|
||||
}
|
||||
|
||||
## @method void _lmLog(string $msg, string $level)
|
||||
# logs message $msg to STDERR with level $level
|
||||
# set Env Var lmLogLevel to set loglevel; set to "info" by default
|
||||
# @param $msg string message to log
|
||||
# @param $level string loglevel
|
||||
sub _lmLog {
|
||||
my ( $class, $msg, $level ) = @_;
|
||||
print STDERR "[$level] $msg\n";
|
||||
}
|
||||
|
||||
## @method void set_user(string user)
|
||||
# sets remote_user
|
||||
# @param user string username
|
||||
sub set_user {
|
||||
my ( $class, $user ) = @_;
|
||||
$ENV{REMOTE_USER} = $user;
|
||||
}
|
||||
|
||||
## @method string header_in(string header)
|
||||
# returns request header value
|
||||
# @param header string request header
|
||||
# @return request header value
|
||||
sub header_in {
|
||||
my ( $class, $header ) = @_;
|
||||
$header ||= $class; # to use header_in as a method or as a function
|
||||
return $ENV{ cgiName($header) };
|
||||
}
|
||||
|
||||
## @method void set_header_in(hash headers)
|
||||
# sets or modifies request headers
|
||||
# @param headers hash containing header names => header value
|
||||
sub set_header_in {
|
||||
my ( $class, %headers ) = @_;
|
||||
while ( my ( $h, $v ) = each %headers ) {
|
||||
$ENV{ cgiName($h) } = $v;
|
||||
}
|
||||
}
|
||||
|
||||
## @method void unset_header_in(array headers)
|
||||
# removes request headers
|
||||
# @param headers array with header names to remove
|
||||
sub unset_header_in {
|
||||
my ( $class, @headers ) = @_;
|
||||
foreach my $h (@headers) {
|
||||
$ENV{ cgiName($h) } = undef;
|
||||
}
|
||||
}
|
||||
|
||||
## @method void set_header_out(hash headers)
|
||||
# sets response headers
|
||||
# @param headers hash containing header names => header value
|
||||
sub set_header_out {
|
||||
my ( $class, %headers ) = @_;
|
||||
while ( my ( $h, $v ) = each %headers ) {
|
||||
push @{ $request->{respHeaders} }, "-$h" => $v;
|
||||
}
|
||||
}
|
||||
|
||||
## @method string hostname
|
||||
# returns host, as set by full URI or Host header
|
||||
# @return host string Host value
|
||||
sub hostname {
|
||||
my $s = $ENV{SERVER_NAME};
|
||||
$s =~ s/:\d+$//;
|
||||
return $s;
|
||||
}
|
||||
|
||||
## @method string remote_ip
|
||||
# returns client IP address
|
||||
# @return IP_Addr string client IP
|
||||
sub remote_ip {
|
||||
return $ENV{REMOTE_ADDR};
|
||||
}
|
||||
|
||||
## @method boolean is_initial_req
|
||||
# always returns true
|
||||
# @return is_initial_req boolean
|
||||
sub is_initial_req {
|
||||
return 1;
|
||||
}
|
||||
|
||||
## @method string args(string args)
|
||||
# gets the query string
|
||||
# @return args string Query string
|
||||
sub args {
|
||||
return $ENV{QUERY_STRING};
|
||||
}
|
||||
|
||||
## @method string uri
|
||||
# returns the path portion of the URI, normalized, i.e. :
|
||||
# * URL decoded (characters encoded as %XX are decoded,
|
||||
# except ? in order not to merge path and query string)
|
||||
# * references to relative path components "." and ".." are resolved
|
||||
# * two or more adjacent slashes are merged into a single slash
|
||||
# @return path portion of the URI, normalized
|
||||
sub uri {
|
||||
my $uri = $ENV{SCRIPT_NAME};
|
||||
$uri =~ s#//+#/#g;
|
||||
$uri =~ s#\?#%3F#g;
|
||||
return $uri;
|
||||
}
|
||||
|
||||
## @method string uri_with_args
|
||||
# returns the URI, with arguments and with path portion normalized
|
||||
# @return URI with normalized path portion
|
||||
sub uri_with_args {
|
||||
return &uri . ( $ENV{QUERY_STRING} ? "?$ENV{QUERY_STRING}" : "" );
|
||||
}
|
||||
|
||||
## @method string unparsed_uri
|
||||
# returns the full original request URI, with arguments
|
||||
# @return full original request URI, with arguments
|
||||
sub unparsed_uri {
|
||||
return $ENV{REQUEST_URI};
|
||||
}
|
||||
|
||||
## @method string get_server_port
|
||||
# returns the port the server is receiving the current request on
|
||||
# @return port string server port
|
||||
sub get_server_port {
|
||||
return $ENV{SERVER_PORT};
|
||||
}
|
||||
|
||||
## @method string method
|
||||
# returns the request method
|
||||
# @return port string server port
|
||||
sub method {
|
||||
return $ENV{METHOD};
|
||||
}
|
||||
|
||||
## @method void print(string data)
|
||||
# write data in HTTP response body
|
||||
# @param data Text to add in response body
|
||||
sub print {
|
||||
my ( $class, $data ) = @_;
|
||||
$request->{respBody} .= $data;
|
||||
}
|
||||
|
||||
sub cgiName {
|
||||
my $h = uc(shift);
|
||||
$h =~ s/-/_/g;
|
||||
return "HTTP_$h";
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,143 +0,0 @@
|
|||
# Auto-protected CGI mechanism
|
||||
package Lemonldap::NG::Handler::CGI;
|
||||
|
||||
use strict;
|
||||
|
||||
use Lemonldap::NG::Common::CGI;
|
||||
use Lemonldap::NG::Handler::Main;
|
||||
use base qw(Lemonldap::NG::Common::CGI Lemonldap::NG::Handler::Main);
|
||||
|
||||
our $VERSION = '2.0.0';
|
||||
|
||||
## @cmethod Lemonldap::NG::Handler::CGI new(hashRef args)
|
||||
# Constructor.
|
||||
# @param $args configuration parameters
|
||||
# @return new object
|
||||
sub new {
|
||||
my ( $class, $args ) = @_;
|
||||
my $self = $class->SUPER::new() or $class->abort("Unable to build CGI");
|
||||
Lemonldap::NG::Handler::Main->init($args);
|
||||
Lemonldap::NG::Handler::Main->checkConf($self);
|
||||
|
||||
# Get access control rule
|
||||
my $rule = $self->{protection}
|
||||
|| Lemonldap::NG::Handler::Main->localConfig->{protection};
|
||||
$rule =~ s/^rule\s*:?\s*//;
|
||||
return $self if ( $rule eq "none" );
|
||||
$rule =
|
||||
$rule eq "authenticate" ? "accept" : $rule eq "manager" ? "" : $rule;
|
||||
my $request = {};
|
||||
my $res = $self->run($rule);
|
||||
|
||||
if ( $res == 403 ) {
|
||||
$self->abort( 'Forbidden',
|
||||
"You don't have rights to access this page" );
|
||||
}
|
||||
elsif ($res) {
|
||||
print $self->header( -status => $res, @{ $request->{respHeaders} } );
|
||||
$self->quit;
|
||||
}
|
||||
else {
|
||||
return $self;
|
||||
}
|
||||
}
|
||||
|
||||
## @method hashRef user()
|
||||
# @return hash of user datas
|
||||
sub user {
|
||||
return Lemonldap::NG::Handler::Main->datas;
|
||||
}
|
||||
|
||||
## @method boolean group(string group)
|
||||
# @param $group name of the Lemonldap::NG group to test
|
||||
# @return boolean : true if user is in this group
|
||||
sub group {
|
||||
my ( $self, $group ) = @_;
|
||||
return ( Lemonldap::NG::Handler::Main->datas->{groups} =~ /\b$group\b/ );
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
=encoding utf8
|
||||
|
||||
Lemonldap::NG::Handler::CGI - Perl extension for using Lemonldap::NG
|
||||
authentication in Perl CGI without using Lemonldap::NG::Handler -
|
||||
DEPRECATED
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Lemonldap::NG::Handler::CGI;
|
||||
my $cgi = Lemonldap::NG::Handler::CGI->new ( {} );
|
||||
|
||||
# See CGI(3) for more about writing HTML pages
|
||||
print $cgi->header;
|
||||
print $cgi->start_html;
|
||||
|
||||
# Since authentication phase, you can use user attributes and macros
|
||||
my $name = $cgi->user->{cn};
|
||||
|
||||
# Instead of using "$cgi->user->{groups} =~ /\badmin\b/", you can use
|
||||
if( $cgi->group('admin') ) {
|
||||
# special html code for admins
|
||||
}
|
||||
else {
|
||||
# another HTML code
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Lemonldap::NG::Handler provides the protection part of Lemonldap::NG web-SSO
|
||||
system. It can be used with any system used with Apache (PHP or JSP pages for
|
||||
example). If you need to protect only few Perl CGI, you can use this library
|
||||
instead.
|
||||
|
||||
Warning, this module must not be used in a Lemonldap::NG::Handler protected
|
||||
area because it hides Lemonldap::NG cookies.
|
||||
|
||||
This package has been deprecated in favor of FastCGI/PSGI files.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<http://lemonldap-ng.org/>, L<Lemonldap::NG::Handler::PSGI>,
|
||||
L<Lemonldap::NG::Handler::PSGI::Router>, L<Lemonldap::NG::Handler::PSGI::Server>,
|
||||
L<Lemonldap::NG::Handler::PSGI::Try>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over
|
||||
|
||||
=item LemonLDAP::NG team L<http://lemonldap-ng.org/team>
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUG REPORT
|
||||
|
||||
Use OW2 system to report bug or ask for features:
|
||||
L<http://jira.ow2.org>
|
||||
|
||||
=head1 DOWNLOAD
|
||||
|
||||
Lemonldap::NG is available at
|
||||
L<http://forge.objectweb.org/project/showfiles.php?group_id=274>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
See COPYING file for details.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
the Free Software Foundation; either version 2, or (at your option)
|
||||
any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License
|
||||
along with this program. If not, see L<http://www.gnu.org/licenses/>.
|
||||
|
||||
=cut
|
||||
|
|
@ -1,60 +0,0 @@
|
|||
# Before `make install' is performed this script should be runnable with
|
||||
# `make test'. After `make install' it should work as `perl Lemonldap-NG-Handler-CGI.t'
|
||||
|
||||
#########################
|
||||
|
||||
# change 'tests => 1' to 'tests => last_test_to_print';
|
||||
|
||||
use Test::More tests => 1;
|
||||
use Cwd 'abs_path';
|
||||
use File::Basename;
|
||||
use File::Temp;
|
||||
|
||||
my $ini = File::Temp->new();
|
||||
my $dir = dirname( abs_path($0) );
|
||||
|
||||
print $ini "[all]
|
||||
|
||||
[configuration]
|
||||
type=File
|
||||
dirName=$dir
|
||||
";
|
||||
|
||||
$ini->flush();
|
||||
|
||||
use Env qw(LLNG_DEFAULTCONFFILE);
|
||||
$LLNG_DEFAULTCONFFILE = $ini->filename;
|
||||
|
||||
use_ok('Lemonldap::NG::Handler::CGI');
|
||||
|
||||
# sub Lemonldap::NG::Handler::CGI::lmLog { }
|
||||
|
||||
#########################
|
||||
|
||||
# Insert your test code below, the Test::More module is use()ed here so read
|
||||
# its man page ( perldoc Test::More ) for help writing this test script.
|
||||
|
||||
__END__
|
||||
my $p;
|
||||
|
||||
# CGI Environment
|
||||
$ENV{SCRIPT_NAME} = '/test.pl';
|
||||
$ENV{SCRIPT_FILENAME} = '/tmp/test.pl';
|
||||
$ENV{REQUEST_METHOD} = 'GET';
|
||||
$ENV{REQUEST_URI} = '/';
|
||||
$ENV{QUERY_STRING} = '';
|
||||
|
||||
ok(
|
||||
$p = Lemonldap::NG::Handler::CGI->new(
|
||||
{
|
||||
configStorage => {
|
||||
confFile => 'undefined.xx',
|
||||
},
|
||||
https => 0,
|
||||
portal => 'http://auth.example.com/',
|
||||
globalStorage => 'Apache::Session::File',
|
||||
}
|
||||
),
|
||||
'Portal object'
|
||||
);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user