CGISession
view release on metacpan or search on metacpan
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
The name of the CGI parameter which contains the passkey.
=item -debug
Set to non-zero to generate debugging information.
=back
=cut
sub new($$@)
{
my ( $type ) = shift;
my ( $cgi ) = shift;
my $self = {};
bless $self, $type;
# A cgi is required.
#
$self->cgi($cgi);
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
my $session = new CGI::LDAPSession;
$session->create_cookie_table;
exit;
Fill out your CGI::LDAPSession just like your going to make
a connection. Call this routine, and voila! Your database
tables are created.
=cut
sub create_cookie_table($)
{
my ($self) = @_;
my $cookie_table = $self->cookie_table;
my $user_column = $self->user_column;
my $cookie_column = $self->cookie_column;
my $passkey_column = $self->passkey_column;
$self->ConnectToDatabase;
$self->SendSQL( "CREATE TABLE $cookie_table ( $user_column varchar(64), $cookie_column varchar(32), $passkey_column bigint(20) )" );
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
# The cgi document which this session is connected to.
#
=item CGI::LDAPSession::cgi
Accessor method. The cgi to which the session is attached.
=cut
sub cgi($;$) { my $self=shift; @_ ? $self->{cgi}=shift : $self->{cgi}; }
#################################
######### Authentication results.
=item CGI::LDAPSession::cookie
Accessor method. The value of the current cookie.
=cut
#################################
sub cookie($;$) { my $self=shift; @_ ? $self->{cookie}=shift : $self->{cookie}; }
=item CGI::LDAPSession::passkey
Accessor method. The value of the current passkey. Set by confirmed() and authenticated().
=cut
sub passkey($;$) { my $self=shift; @_ ? $self->{passkey}=shift : $self->{passkey}; }
#################################
=item CGI::LDAPSession::is_authenticated
Accessor method. Authentication state. True if the session has been successfully authenticated. False if it has not.
=cut
sub is_authenticated($;$) { my $self=shift; @_ ? $self->{is_authenticated}=shift : $self->{is_authenticated}; }
# Fast initialization routine.
#
sub set($@)
{
my ( $self ) = shift;
my %a = @_;
$self->cookie_logged_in( $a{'-cookie_logged_in'} ) if defined $a{'-cookie_logged_in'};
$self->cookie_logged_in( $a{'-cookie_name'} ) if defined $a{'-cookie_name'};
$self->cookie_expiration( $a{'-cookie_expiration'} ) if defined $a{'-cookie_expiration'};
$self->cookie_path( $a{'-cookie_path'} ) if defined $a{'-cookie_path'};
$self->cookie_domain( $a{'-cookie_domain'} ) if defined $a{'-cookie_domain'};
$self->cookie_secure( $a{'-cookie_secure'} ) if defined $a{'-cookie_secure'};
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
These accessor methods specify the details of the cookies which are generated.
=item CGI::LDAPSession::cookie_logged_in($;$)
Accessor method. The name of the login cookie. Use cookie_name instead.
=cut
sub cookie_logged_in($;$) { my $self=shift; @_ ? $self->{cookie_logged_in}=shift : $self->{cookie_logged_in}; }
=item CGI::LDAPSession::cookie_name($;$)
Accessor method. The name of the login cookie. Use this instead of cookie_logged_in.
=cut
sub cookie_name($;$) { my $self=shift; @_ ? $self->{cookie_logged_in}=shift : $self->{cookie_logged_in}; }
=item CGI::LDAPSession::cookie_logged_out($;$)
Accessor method. Vestigial logout cookie. Unused. Like the wings of an archeopertyx. But with no hairy feathers.
=cut
sub cookie_logged_out($;$) { my $self=shift; @_ ? $self->{cookie_logged_out}=shift : $self->{cookie_logged_out}; }
=item CGI::LDAPSession::cookie_expiration($;$)
Accessor method. The lifetime of the cookie specified in seconds.
=cut
sub cookie_expiration($;$) { my $self=shift; @_ ? $self->{cookie_expiration}=shift : $self->{cookie_expiration}; }
=item CGI::LDAPSession::cookie_path($;$)
Accessor method. The path of the cookie.
=cut
sub cookie_path($;$) { my $self=shift; @_ ? $self->{cookie_path}=shift : $self->{cookie_path}; }
=item CGI::LDAPSession::cookie_domain($;$)
Accessor method. The domain of the cookie.
=cut
sub cookie_domain($;$) { my $self=shift; @_ ? $self->{cookie_domain}=shift : $self->{cookie_domain}; }
=item CGI::LDAPSession::cookie_secure($;$)
Accessor method. True if the cookie requires SSL. False otherwise.
=cut
sub cookie_secure($;$) { my $self=shift; @_ ? $self->{cookie_secure}=shift : $self->{cookie_secure}; }
# Login behavior
#
=item Authentication Behavior Variables
These are variables which affect the behavior of the authentication mechanism.
=item CGI::LDAPSession::auth_servers($;$)
Accessor method. The list of authentication servers which will be contacted. This value can either
be a single server or a reference to an array of servers.
Currently these servers are definied by CGI::LDAPSession::LDAPServer objects.
=cut
sub auth_servers($;$) { my $self=shift; @_ ? $self->{auth_servers}=shift : $self->{auth_servers}; }
=item CGI::LDAPSession::restricted_access($;$)
Accessor method. If set to a non-zero value then the allowed_user_file is turned on.
=cut
sub restricted_access($;$) { my $self=shift; @_ ? $self->{restricted_access}=shift : $self->{restricted_access}; }
=item CGI::LDAPSession::allowed_user_file($;$)
Accessor method. The full path to the allowed_user_file.
=cut
sub allowed_user_file($;$) { my $self=shift; @_ ? $self->{allowed_user_file}=shift : $self->{allowed_user_file}; }
=item CGI::LDAPSession::unikey($;$)
Accessor method. Boy this one sucks. This is a backdoor value. If this is
set then any user matching this ID will be successfully authenticated. Why? Strictly
for testing. NEVER, EVER SET THIS VALUE UNLESS YOU KNOW WHAT THE FUCK YOU ARE DOING.
=cut
sub unikey($;$) { my $self=shift; @_ ? $self->{unikey}=shift : $self->{unikey}; }
=item CGI::LDAPSession::register($;$)
Accessor method. Login requires an entry to exist in the cookie table for each user.
If this variable is set then an entry will automatically be created for users which are
successfully authenticated.
=cut
sub register($;$) { my $self=shift; @_ ? $self->{register}=shift : $self->{register}; }
=item CGI::LDAPSession::auto_refresh_cookie($;$)
Accessor method. Normally the cookie will expire X seconds after it is created, where X is
specified by CGI::LDAPSession::cookie_expiration. Whenever the cookie is refreshed this
timer resets. Setting this variable to a non-zero value causes the cookie to be refreshed
every time that it is successfully verified.
=cut
sub auto_refresh_cookie($;$) { my $self=shift; @_ ? $self->{auto_refresh_cookie}=shift : $self->{auto_refresh_cookie}; }
=item CGI::LDAPSession::used_with_custom_cgi($;$)
Forget about this one. This is an internal function used by CGI::LDAPSession and CGI::LDAPSession::CGI.
Normally set to zero. Setting CGI::LDAPSession::CGI::session causes this value to be set.
=cut
sub used_with_custom_cgi($;$) { my $self=shift; @_ ? $self->{used_with_custom_cgi}=shift : $self->{used_with_custom_cgi}; }
# DBI structures and connection state.
#
=item DBI Structures and Connection State
Interal accessor methods pertaining to various aspects of the database connection.
These WILL change in future releases, and are documented here for the developer's
use.
=item CGI::LDAPSession::dbi($;$)
Accessor method. The active DBI connection. The connection to the database will be created
when first required, and the DBI connection will be cached in this variable.
=cut
sub dbi($;$) { my $self=shift; @_ ? $self->{dbi}=shift : $self->{dbi}; }
=item CGI::LDAPSession::dbi_statement($;$)
Accessor method. Internal use only. The current DBI statement.
=cut
sub dbi_statement($;$) { my $self=shift; @_ ? $self->{dbi_statement}=shift : $self->{dbi_statement}; }
=item CGI::LDAPSession::dbi_results($;$)
Accessor method. Internal use only. The current results object.
=cut
sub dbi_results($;$) { my $self=shift; @_ ? $self->{dbi_results}=shift : $self->{dbi_results}; }
=item CGI::LDAPSession::dbi_results($;$)
Accessor method. Internal use only. The prefetched results from a results object.
Not really necessary with DBI, but I haven't altered the original authentication logic
that required this.
=cut
sub dbi_prefetch($;$) { my $self=shift; @_ ? $self->{dbi_prefetch}=shift : $self->{dbi_prefetch}; }
# Database connection.
#
=item Variables describing the database connection.
These are variables which are used to make the database connection. They
must be specified in order to make a connection.
=item CGI::LDAPSession::dbi_dn($;$)
Accessor method. DBI connection string.
=cut
sub dbi_dn($;$) { my $self=shift; @_ ? $self->{dbi_dn}=shift : $self->{dbi_dn}; }
=item CGI::LDAPSession::dbi_password($;$)
Accessor method. Password for the connection.
=cut
sub dbi_password($;$) { my $self=shift; @_ ? $self->{dbi_password}=shift : $self->{dbi_password}; }
=item CGI::LDAPSession::dbi_username($;$)
Accessor method. Username for the connection.
=cut
sub dbi_username($;$) { my $self=shift; @_ ? $self->{dbi_username}=shift : $self->{dbi_username}; }
# Login/cookie table description.
#
=item Database tables
The names of the database tables.
=item CGI::LDAPSession::cookie_table($;$)
Accessor method. The name of the cookie table.
=cut
sub cookie_table($;$) { my $self=shift; @_ ? $self->{cookie_table}=shift : $self->{cookie_table}; }
=item CGI::LDAPSession::user_column($;$)
Accessor method. The column containing the usernames.
=cut
sub user_column($;$) { my $self=shift; @_ ? $self->{dbi_user_column}=shift : $self->{dbi_user_column}; }
=item CGI::LDAPSession::passkey_column($;$)
Accessor method. The column containing the passkey.
=cut
sub passkey_column($;$) { my $self=shift; @_ ? $self->{dbi_passkey_column}=shift : $self->{dbi_passkey_column}; }
=item CGI::LDAPSession::cookie_column($;$)
Accessor method. The column containing the cookie id.
=cut
sub cookie_column($;$) { my $self=shift; @_ ? $self->{dbi_cookie_column}=shift : $self->{dbi_cookie_column}; }
=item CGI::LDAPSession::login_expiration_column($;$)
Accessor method. The expiration time for the cookie. Currently not
used, but it will be used in the future.
=cut
sub login_expiration_column($;$) { my $self=shift; @_ ? $self->{dbi_login_expiration_column}=shift : $self->{dbi_login_expiration_column}; }
=item CGI::LDAPSession::passkey_name($;$)
Accessor method. The name of the passkey field in the form is stored here.
Not currently important, but it will be if/when the table becomes a shared
resource.
=cut
sub passkey_name($;$) { my $self=shift; @_ ? $self->{passkey_name}=shift : $self->{passkey_name}; }
=item CGI::LDAPSession::debug($;$)
Accessor method. Turns on debugging. Currently this doesn't do much. I need
to add more instrumentation.
=cut
sub debug($;$) { my $self=shift; @_ ? $self->{debug}=shift : defined $self->{debug}; }
#sub %($;$) { my $self=shift; @_ ? $self->{%}=shift : $self->{%}; }
##############################
# #
# Some LDAP Related Routines #
# #
##############################
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
$server = new CGI::LDAPSession::LDAPServer( -host => 'myhost',
-port => 389,
-base => 'ou=People,dc=inktomi,dc=com',
-bind => 'uid=$username,ou=People,dc=inktomi,dc=com' );
my %mozilla_ldap = $self->setup_ldap_auth( $ldap_server, $user, $password );
=cut
sub setup_ldap_auth($$$$)
{
my ($self,$ldap_server,$username,$password) = @_;
$username = defined $username ? $username : "" ;
# get the args and set some defaults
my %ld = Mozilla::LDAP::Utils::ldapArgs();
$ld{host} = $ldap_server->host;
$ld{port} = $ldap_server->port;
$ld{root} = $ldap_server->root;
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
=item CGI::LDAPSession::has_passkey
True if the CGI session has a value for the parameter specified with
-passkey_name.
print "Session has passkey: ".( $session->has_passkey ? "YES" : "NO" )."\n";
=cut
sub has_passkey($)
{
my $self = shift;
return $self->cgi->param($self->passkey_name);
}
=item CGI::LDAPSession::passkey_field
The value of the CGI parameter specified by -passkey_name.
$passkey_field = $session->passkey_field;
=cut
sub passkey_field($)
{
my $self = shift;
my $passkey = $self->passkey;
my $passkey_name = $self->passkey_name;
return qq(<input type=hidden name="$passkey_name" value="$passkey">);
}
# Confirm the existance of the session
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
If you want to handle the extraction of the passkey on your own...
my $passkey = $cgi->param( 'passkey_name' );
if ( $session->confirmed( $passkey ) )
{
Session was confirmed...
}
=cut
sub confirmed($;$)
{
my ($self) = shift;
my $passkey = @_ ? shift : $self->cgi->param( $self->passkey_name );
carp "Passkey is $passkey";
my $client_cookie;
my $db_passkey;
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
{
Authentication Succeeded
}
else
{
Authentication Failed
}
=cut
sub confirm($;$) { my $self = shift; $self->confirmed(@_); }
# Authenticate User (at beginning)
#
# $session->authenticated( $username, $password );
#
# 1 = SUCCESS
# 0 = FAILURE
#
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
{
Authentication Succeeded
}
else
{
Authentication Failed
}
=cut
sub authenticated($$$) {
my ($self,$username, $password) = @_;
$username = defined $username ? $username : "";
$password = defined $password ? $password : "";
# the skeleton key!
#
if( defined $self->unikey && ($password eq $self->unikey))
{
$self->is_authenticated(1);
return 1;
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
{
Authentication Succeeded
}
else
{
Authentication Failed
}
=cut
sub authenticate($$$)
{
my ( $self, $username, $password ) = @_;
if ( $self->authenticated( $username, $password ) )
{
$self->set_passkey( $username );
$self->set_login_cookie( $username );
}
}
##############################################################
#
# Wrapper for CGI.pm's header function which transparently
# handles creation of the cookie.
#
sub header_args_with_cookie($@)
{
my ($self,%raw_args) = @_;
# Copy the arguments. If we find a cookie argument
# then we add in any cookies that we already know about.
#
my @processed_args ;
my $cookie_is_done = 0;
foreach my $arg (keys %raw_args)
{
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
of CGI.pm's header method.
print $session->header;
print $cgi->start_html( 'my html' );
...
=back
=cut
sub header($@)
{
my ($self) = shift;
my $header;
# If this is being used with a custom CGI, then we just call the
# custom CGI which understands how to use the header_args_with_cookie
# to inject the cookie. This call shouldn't be hear, but it was
# put in before I had really thought through the use of a custom
# CGI.pm wrapper. (Otherwise we end up with duplicate cookies.)
#
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
}
######################
# #
# Some MySQL-Related #
# Functions #
# #
######################
sub ConnectToDatabase($)
{
my $self = shift;
if ( !defined $self->dbi )
{
my $dbi = DBI->connect( $self->dbi_dn, $self->dbi_username, $self->dbi_password );
if ( !$dbi )
{
croak "Can't connect to database server for cookie handling.";
}
$self->dbi( $dbi );
}
return 0;
}
sub DisconnectDatabase($)
{
my ($self) = @_;
if ( $self->dbi )
{
$self->dbi_statement->finish if $self->dbi_statement;
$self->dbi->disconnect;
}
# Close everyting up no matter what the state of the
# dbi connection.
#
$self->dbi( undef );
$self->dbi_statement( undef );
return 0;
}
sub FinishAnyExistingStatement($)
{
my ($self) = @_;
if ( $self->dbi and $self->dbi_statement )
{
$self->dbi_statement->finish;
}
$self->dbi_statement( undef );
}
sub SendSQL($$)
{
my ($self,$query) = @_;
# Never do anything unless we have an active dbi connection.
#
if ( !defined $self->dbi )
{
croak "Programmer error: Tried to use SendSQL without first calling ConnectDB.";
}
my $dbi = $self->dbi;
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
$statement->finish;
croak "Database access error: $DBI::err: $DBI::errstr\n";
}
$self->dbi_statement( $statement );
# Clear prefetch.
#
$self->dbi_prefetch( undef );
}
sub MoreSQLData($)
{
my ($self) = @_;
if (!defined $self->dbi)
{
croak "Programmer Error: Attempted to get data from a closed DBI connection.\n ".
"This is not supported.\n";
}
if (defined $self->dbi_prefetch)
{
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
{
croak "Assertion Failure: Should never attempt to finish a DBI ".
"statement which has already been closed.";
}
$self->FinishAnyExistingStatement;
return 0;
}
}
sub FetchSQLData($)
{
my $self = shift;
if (!defined $self->dbi)
{
croak "Programmer Error: Attempted to get data from a closed DBI connection.\n ".
"This is not supported.\n";
}
# Return a prefetch value if it exists.
#
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
if (!defined $self->dbi_statement)
{
croak "Programmer Error: Attempted to get data from a DBI connection which has \n".
"no active statement.\n";
}
return $self->dbi_statement->fetchrow_array;
}
sub FetchOneColumn($)
{
my ($self) = @_;
my @row = $self->FetchSQLData();
return $row[0];
}
=item CGI::LDAPSession::user_exists
Internal function. Checks the database to see if a user has an existing
record within the cookie table. True if the cookie table contains
an entry for the username, and false if it does not.
if ( $self->user_exists( $username ) )
{
... perform action for defined user ...
}
=cut
sub user_exists($$)
{
my ($self,$username) = @_;
my $cookie_table = $self->cookie_table;
my $user_column = $self->user_column;
my $cookie_column = $self->cookie_column;
my $passkey_column = $self->passkey_column;
$self->ConnectToDatabase;
$self->SendSQL("SELECT count($user_column) FROM $cookie_table WHERE $user_column='$username'");
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
Internal function. Creates an entry for the specified user within the cookie table.
if ( ! $self->user_exists( $username ) )
{
$self->register_username( $username );
}
=cut
sub register_username($$)
{
my ($self,$username) = @_;
return unless $self->register;
return if $self->user_exists($username);
my $cookie_table = $self->cookie_table;
my $user_column = $self->user_column;
my $cookie_column = $self->cookie_column;
my $passkey_column = $self->passkey_column;
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
=item CGI::LDAPSession::login_cookie($$$)
Internal function. Returns the cookie string for the current session. The
expiration time is a unix timestamp as returned by the function time(). The
expiration time is not a lifetime in seconds.
my $cookie_string = $self->login_cookie( $cookie_name, $expiration_time );
=cut
sub login_cookie($$$)
{
my ($self,$cookie_value,$expiration_time) = @_;
my $datetimestr = time2str("%a, %e-%b-%Y %X GMT", $expiration_time, 'GMT');
my $cgi = $self->cgi;
my $cookie = $cgi->cookie( -name=>$self->cookie_logged_in,
-value=>$cookie_value,
-path=>$self->cookie_path,
-domain=>$self->cookie_domain,
-secure=>($self->cookie_secure ? 1 : 0 ),
-expires=>$datetimestr );
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
current cookie and passkey combination.
$self->set_login_cookie( $username );
..or..
$self->set_login_cookie();
=cut
sub set_login_cookie($;$)
{
my ($self) = shift;
my $cookie_table = $self->cookie_table;
my $user_column = $self->user_column;
my $cookie_column = $self->cookie_column;
my $passkey_column = $self->passkey_column;
$self->ConnectToDatabase;
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
=item CGI::LDAPSession::refresh_login_cookie($)
Resets the expiration time for the current cookie.
$self->refresh_login_cookie();
=cut
sub refresh_login_cookie($)
{
my ($self) = @_;
my $cookie_value = $self->cgi->cookie($self->cookie_logged_in);
my $expire = time + $self->cookie_expiration;
my $cookie = $self->login_cookie( $cookie_value, $expire );
$self->cookie( $cookie );
}
=item CGI::LDAPSession::username($)
Pulls the username for the current cookie/passkey pair from
the database.
my $username = $self->username();
=cut
sub username($)
#
# Gets the user ID for the current session.
#
# my $username = $session->username;
#
{
my ( $self ) = @_;
my $cookie_table = $self->cookie_table;
my $user_column = $self->user_column;
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
it can be extracted automatically by the session.
$self->set_passkey( $username );
..or..
$self->set_passkey();
=cut
sub set_passkey($;$)
{
my ($self) = shift;
my $pass = int(rand 9999999)+1;
my $cookie_table = $self->cookie_table;
my $user_column = $self->user_column;
my $cookie_column = $self->cookie_column;
my $passkey_column = $self->passkey_column;
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
=item CGI::LDAPSession::logout_cookie($)
Returns a login_cookie which has expired. (Expiration date
is set to epoch.)
my $cookie = $self->logout_cookie();
=cut
sub logout_cookie($)
{
my ($self) = @_;
my $datetimestr = "Thu, 01-Jan-2000 00:00:01 GMT";
my $cgi = $self->cgi;
my $cookie = $cgi->cookie( -name=>$self->cookie_logged_in,
-value=>{},
-path=>$self->cookie_path,
-domain=>$self->cookie_domain,
-secure=>($self->cookie_secure ? 1 : 0 ),
-expires=>$datetimestr );
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
# logout here (as far as cookies are concerned)
#
=item CGI::LDAPSession::set_logout_cookie($)
Expires the cookie in the backing store.
my $cookie = $self->set_logout_cookie();
=cut
sub set_logout_cookie($)
{
my ($self) = @_;
my $logout_cookie = $self->logout_cookie;
$self->cookie( $logout_cookie );
# SUCCESS
return 0;
}
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
#
=item CGI::LDAPSession::check_cookie($)
Returns the cookie for this session if it exists. If a
cookie does not exist then it returns nothing.
my $login_cookie = $self->check_cookie();
=cut
sub check_cookie($)
{
my ($self) = @_;
return $self->cgi->cookie($self->cookie_logged_in);
}
#######################################################################################
#
# An LDAP server
#
package CGI::LDAPSession::LDAPServer;
use strict;
sub new($;@)
{
my ( $type ) = shift;
my %args = @_;
my $self = {};
bless $self, $type;
# set other parameters if needed.
#
$self->host( $args{'-host'} ) if $args{'-host'};
$self->port( $args{'-port'} ) if $args{'-port'};
$self->root( $args{'-root'} ) if $args{'-root'};
$self->base( $args{'-base'} ) if $args{'-base'};
$self->bind( $args{'-bind'} ) if $args{'-bind'};
return $self;
}
sub host($;$) { my $self=shift; @_ ? $self->{host}=shift : $self->{host}; }
sub port($;$) { my $self=shift; @_ ? $self->{port}=shift : $self->{port}; }
sub root($;$) { my $self=shift; @_ ? $self->{root}=shift : $self->{root}; }
sub base($;$) { my $self=shift; @_ ? $self->{base}=shift : $self->{base}; }
sub bind($;$) { my $self=shift; @_ ? $self->{bind}=shift : $self->{bind}; }
sub set_mozilla_LDAP_args_in($$)
{
my ( $self, $args ) = @_;
$args->{host} = $self->host;
$args->{port} = $self->port;
$args->{root} = $self->root;
$args->{base} = $self->base;
$args->{bind} = $self->bind;
return $args;
Session/CVS/Base/LDAPSession.pm view on Meta::CPAN
use CGI::Carp;
use vars qw( @ISA );
@ISA = qw( CGI );
my %_params = ( -errors => __PACKAGE__.".errors",
-messages => __PACKAGE__.".messages",
-session => __PACKAGE__.".session", );
sub errors($;$) { _param( shift, "-errors", @_ ); }
sub messages($;$) { _param( shift, "-messages", @_ ); }
sub session($;$)
{
my $self = shift;
if ( @_ )
{
my $session = shift;
#
# If someone is unsetting the session then @_ will be
# defined, but $session will not. In this case we
# skip setting the 'used_with_custom_cgi' flag.
#
$session->used_with_custom_cgi( 1 ) if defined $session ;
_param( $self, "-session", $session );
}
else
{
return _param( $self, "-session" );
}
}
sub _param($@)
{
my $self = shift;
if ( scalar @_ == 1 )
{
my $field = shift;
my $slot = $_params{$field};
croak "Programmer Error: $field is not a known parameter" unless defined $slot;
return $self->{$slot};
}
else
{
while( my $field = shift )
{
my $slot = $_params{$field};
croak "Programmer Error: $field is not a known parameter" unless defined $slot;
$self->{$slot} = shift;
}
}
}
sub set($@) { _param(shift,@_); }
sub add_error($$)
{
my ( $self, $error ) = @_;
push @{ $self->errors}, $error ;
}
sub has_errors($) { return scalar @{shift->errors}; }
sub add_message($$)
{
my ( $self, $message ) = @_;
push @{$self->messages}, $message;
}
sub has_messages($) { return scalar @{shift->messages}; }
sub new($;)
{
my $type = shift;
my $self = $type->SUPER::new;
$self->errors([]);
$self->messages([]);
return $self;
}
sub header($;@)
{
my $self = shift;
my $header;
if ( defined $self->session and $self->session )
{
$header = $self->SUPER::header( $self->session->header_args_with_cookie(@_) );
}
else
{
$header = $self->SUPER::header(@_);
}
carp $header;
return $header;
}
sub end_html($;)
{
my $self = shift;
if ( defined $self->session and $self->session )
{
$self->session(undef);
}
return $self->SUPER::end_html(@_);
}
sub end_form($;@)
{
my $self = shift;
my $out = "";
# Inject hidden field with passkey if it exists.
#
if ( defined $self->session and $self->session )
{
my $session = $self->session;
my $passkey = $session->passkey;
my $passkey_name = $session->passkey_name;
if ( defined $passkey and $passkey )
{
$out .= qq(<input type=hidden name="$passkey_name" value="$passkey">\n);
}
}
$out .= $self->SUPER::end_form(@_);
return $out;
}
sub errors_as_html($)
{
my $self = shift;
return undef unless $self->has_errors;
my $out .= qq(<ul>\n);
foreach my $error ( @{$self->errors} )
{
$out .= qq( <li><font color="#ff0000">$error</font></li>\n);
}
$out .= qq(</ul>\n);
return $out;
}
sub messages_as_html($)
{
my $self = shift;
return undef unless $self->has_messages;
my $out .= qq(<ul>\n);
foreach my $message ( @{$self->messages} )
{
$out .= qq( <li>$message</li>\n);
}
$out .= qq(</ul>\n);
return $out;
( run in 1.678 second using v1.01-cache-2.11-cpan-65fba6d93b7 )