^sub \w+\( results from the CPAN

lib/AnyEvent/Worker.pm view on Meta::CPAN


# Almost fully derived from AnyEvent::DBI

our $WORKER;

sub serve_fh($$) {
	my ($fh, $version) = @_;

	if ($VERSION != $version) {
		syswrite $fh,
			pack "L/a*",

lib/AnyEvent/Worker.pm view on Meta::CPAN

		}
	};
	warn if $@;
}

sub serve_fd($$) {
	open my $fh, ">>&=$_[0]"
		or die "Couldn't open server file descriptor: $!";

	serve_fh $fh, $_[1];
}

view all matches for this distribution

AnyEvent-XMPP

2 results

lib/AnyEvent/XMPP/Util.pm view on Meta::CPAN

This function removes all characters from C<$string> which
are not allowed in XML and returns the new string.

=cut

sub filter_xml_chars($) {
   my ($string) = @_;
   $string =~ s/[^\x{9}\x{A}\x{D}\x{20}-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFFFF}]+//g;
   $string
}

view all matches for this distribution

AnyEvent-ZeroMQ

1 match

lib/AnyEvent/ZeroMQ/Types.pm view on Meta::CPAN


subtype Endpoints, as ArrayRef[Endpoint], message {
    'Each endpoint must be in the form "<transport>://<address>"';
};

sub fixup_endpoint() {
    s{(^[/])/$}{$1}g;
}

coerce Endpoint, from Str, via { fixup_endpoint };

view all matches for this distribution

AnyEvent-mDNS

1 match

lib/AnyEvent/mDNS.pm view on Meta::CPAN

use AnyEvent::DNS;
use AnyEvent::Handle::UDP;
use AnyEvent::Socket ();
use Socket;

sub discover($%) { ## no critic
    my $cb = sub {};
    $cb = pop if @_ % 2 == 0;

    my($proto, %args) = @_;

view all matches for this distribution

AnyMQ-Pg

1 match

inc/Test/More.pm view on Meta::CPAN

    return $tb->unlike(@_);
}

#line 476

sub cmp_ok($$$;$) {
    my $tb = Test::More->builder;

    return $tb->cmp_ok(@_);
}

view all matches for this distribution

Aozora2Epub

1 match

lib/Aozora2Epub/XHTML/Tree.pm view on Meta::CPAN

    my ($self, $selector) = @_;
    $selector = _selector($selector);
    return [ $self->_result->findnodes($selector) ];
}

sub _apply(&$) { ## no critic (ProhibitSubroutinePrototypes)
    _apply0(@_);
}

sub _apply0 {
    my ($sub, $elem) = @_;

lib/Aozora2Epub/XHTML/Tree.pm view on Meta::CPAN

        return $sub->($elem);
    }
    return $elem;
}

sub _map_apply(&@) { ## no critic (ProhibitSubroutinePrototypes)
    my ($sub, @nodes) = @_;
    return map { _apply0($sub, $_) } @nodes;
}

sub _result {

view all matches for this distribution

Apache-ACEProxy

1 match

lib/Apache/ACEProxy.pm view on Meta::CPAN


use Apache::Constants qw(:response);
use LWP::UserAgent;
use URI;

sub handler($$) {
    my($class, $r) = @_;
    return DECLINED unless $r->proxyreq;
    $r->handler('perl-script');
    $r->set_handlers(PerlHandler => [ sub { $class->proxy_handler($r); } ]);
    return OK;

view all matches for this distribution

Apache-ASP

1 match

ASP.pm view on Meta::CPAN

    1;
}   

# sub Debug { # for matching
*Debug = *Out; # default
sub Null() { 0; }; # prototype for inlining hopefully
sub Out {
    my($self, @args) = @_;

    # already know because of aliasing
    #    return unless $_[0]->{dbg};

ASP.pm view on Meta::CPAN

  ;

	500;
}

sub CompileChecksumKeys() { \@CompileChecksumKeys };

sub get_dir_config {
    my $rv = shift->get(shift);
    if(!$rv || lc($rv) eq 'off') {
	$rv = 0; # Off always becomes 0

view all matches for this distribution

Apache-App-Mercury

1 match

Mercury/UserManager.pm view on Meta::CPAN

The only requirements of Apache::App::Mercury is it should
return valid values for the above params for the currently
logged-in user.

=cut
sub userprofile($) {}

=item * get_userinfo(@users)

Get user profile information on users that exist in the application
(but not necessarily logged in at the moment).  Input is a list of

Mercury/UserManager.pm view on Meta::CPAN

    mname => 'Middle name or initial of user', #optional
    lname => 'Last name of user',
    e_mail => 'email@forward.to.addr' }

=cut
sub get_userinfo(@) {}

=item * mailboxes($user, [@update_boxes])

Get a list of $user's custom-defined mailboxes, or if called in
set context sets the given user's custom-defined mailboxes to
those specified in @update_boxes.  If called in set context,
return 1 for success, undef on failure.

=cut
sub mailboxes($@) {}

=item * mail_trans_filter([$trans_box])

Get name of mailbox to send transaction-related msgs to for current user.
In set context (if $trans_box is given), sets mailbox to filter

Mercury/UserManager.pm view on Meta::CPAN


Expects the calling object to know what user is logged in,
and the auto_forward() method to have access to that information.

=cut
sub auto_forward($) {}


1;
__END__

view all matches for this distribution

Apache-AppSamurai

1 match

lib/Apache/AppSamurai.pm view on Meta::CPAN

# if they were connecting directly to the backend server(s).
#
# The return should be used to update the alterlist.  When
# AlterlistPassBackCookie is applied again, it will UNSET the passback cookies.
# This should be done on logout.
sub AlterlistPassBackCookie() {
    my ($self, $alterlist, $r) = @_;

    (defined($alterlist->{cookie})) || (return 0);
    my ($t, $key, $val, $opt, $tdomain, $tpath, $texpire);
    my @ct = ();

view all matches for this distribution

Apache-AuthCAS

1 match

	$SESSION_CLEANUP_COUNTER = 0;
}

my $tmp;

sub initialize($$) {
	my $self = shift;
	my $r = shift;

	# get all of our settings from the server config

	# specify that we have been successfully initialized
	$INITIALIZED = 1;
}

# used for underlying services that need proxy tickets (PTs)
sub authenticate($$) {
	my $self = shift;
	my $r = shift;
	my $tmp;

	# Only authenticate the first internal request


	# failed if we got this far, but shouldn't
	return (MP2 ? Apache::FORBIDDEN : Apache::Constants::FORBIDDEN);
}

sub cleanup($$) {
	my $self = shift;
	my $r = shift;

	$SESSION_CLEANUP_COUNTER++;
	Apache->warn("$$: CAS: cleanup(): counter=$SESSION_CLEANUP_COUNTER") unless ($LOG_LEVEL < $LOG_DEBUG);

		# reset counter
		$SESSION_CLEANUP_COUNTER = 0;
	}
}

sub redirect_without_ticket($$) {
	my $self = shift;
	my $r = shift;

	Apache->warn("$$: CAS: redirect_without_ticket(): redirecting to remove service ticket from service string") unless ($LOG_LEVEL < $LOG_INFO);

	my $url = $self->this_url($r);
	$r->header_out("Location" => $url);
	return (MP2 ? Apache::HTTP_MOVED_TEMPORARILY : Apache::Constants::HTTP_MOVED_TEMPORARILY);
}

sub redirect_login($$) {
	my $self = shift;
	my $r = shift;

	Apache->warn("$$: CAS: redirect_login()") unless ($LOG_LEVEL < $LOG_DEBUG);

	my $redirect_url = "https://$CAS_HOST:$CAS_PORT$CAS_LOGIN_URI?service=$service";
	$r->header_out("Location" => $redirect_url);
	return (MP2 ? Apache::HTTP_MOVED_TEMPORARILY : Apache::Constants::HTTP_MOVED_TEMPORARILY);
}

sub redirect($$) {
	my $self = shift;
	my $r = shift;
	my $url = shift || "";
	my $errcode = shift || "";

#     ticket to be validated
#     1 or 0, whether we need proxy tickets
# returns a hash with keys on success
# 	  'user', 'pgtiou'
# NULL on failure
sub validate_service_ticket($$) {
	my $self = shift;
	my $r = shift;
	my $ticket = shift;
	my $proxy = shift;

	}

	return %properties;
}

sub send_proxysuccess($$) {
	my $self = shift;
	my $r = shift;

	Apache->warn("$$: CAS: send_proxysuccess(): sending proxy success for CAS callback") unless ($LOG_LEVEL < $LOG_DEBUG);

	$r->print("<casClient:proxySuccess xmlns:casClient=\"http://www.yale.edu/tp/casClient\"/>\n");
	$r->rflush();
	return (MP2 ? Apache::OK : Apache::Constants::OK);
}

sub get_proxy_tickets($$) {
	my $self = shift;
	my $pgt = shift;
	my $target = shift;
	my $num_tickets = shift;

		return qw();
	}
}

# place data in the session
sub set_session_data($$) {
	my $self = shift;
	my $sid = shift;
	my $last_accessed = shift;
	my $uid = shift;
	my $pgtiou = shift || "";


	return 1;
}

# takes a session id and returns an array
sub get_session_data($$) {
	my $self = shift;
	my $sid = shift;

	Apache->warn("$$: CAS: get_session_data()") unless ($LOG_LEVEL < $LOG_DEBUG);

	Apache->warn("$$: CAS: get_session_data(): couldn't get session data for sid='$sid'") unless ($LOG_LEVEL < $LOG_DEBUG);
	return ();
}

# delete session
sub delete_session_data($$) {
	my $self = shift;
	my $sid = shift;

	Apache->warn("$$: CAS: delete_session_data()") unless ($LOG_LEVEL < $LOG_DEBUG);


	return 1;
}

# delete expired sessions
sub delete_expired_sessions($$) {
	my $self = shift;

	Apache->warn("$$: CAS: delete_expired_sessions()") unless ($LOG_LEVEL < $LOG_DEBUG);

	my $oldest_valid_time = time() - $SESSION_TIMEOUT;


	return 1;
}

# place the pgt mapping in the database
sub set_pgt($$) {
	my $self = shift;
	my $pgtiou = shift;
	my $pgt = shift;

	Apache->warn("$$: CAS: set_pgt()") unless ($LOG_LEVEL < $LOG_DEBUG);


	return 1;
}

# takes a pgtiou and returns a pgt
sub get_pgt($$) {
	my $self = shift;
	my $pgtiou = shift;
	my $sid = shift || "";

	Apache->warn("$$: CAS: get_pgt(): getting pgtiou/pgt map for pgtiou='$pgtiou'") unless ($LOG_LEVEL < $LOG_DEBUG);

	Apache->warn("$$: CAS: get_pgt(): coudln't get pgtiou/pgt map pgtiou='$pgtiou'") unless ($LOG_LEVEL < $LOG_DEBUG);
	return "";
}

# deletes a pgt/pgtiou mapping
sub delete_pgt($$) {
	my $self = shift;
	my $pgtiou = shift;

	Apache->warn("$$: CAS: delete_pgt()") unless ($LOG_LEVEL < $LOG_DEBUG);


	return 1;
}

# delete pgts that have no session associated with 'em and are old
sub delete_expired_pgts($$) {
	my $self = shift;

	Apache->warn("$$: CAS: delete_expired_pgts()") unless ($LOG_LEVEL < $LOG_DEBUG);

	# retrieve a session object for this session id

	$dbh->disconnect();

	return 1;
}

sub do_proxy($$) {
	my $self = shift;
	my $r = shift;
	my $sid = shift;
	my $pgtiou = shift;
	my $user = shift;

		return $self->redirect($r, $ERROR_URL, $INVALID_PGT_ERROR_CODE);
	}
}

# generate a new session id
sub create_session_id() {
	my $sid = "";
	srand();
	for (my $i=0; $i < 32; $i++) {
		$sid .= ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64];
	}

view all matches for this distribution

Apache-AuthCookie

1 match

lib/Apache/AuthCookie.pm view on Meta::CPAN


    return Apache::AuthCookie::Util::escape_destination($dest);
}


sub logout($$) {
    my ($self, $r) = @_;
    my $debug = $r->dir_config("AuthCookieDebug") || 0;

    $self->remove_cookie;

view all matches for this distribution

Apache-AuthCookieDBIRadius

2 results

AuthCookie.pm view on Meta::CPAN

  }
  $r->header_out("Location" => $args{'destination'});
  return REDIRECT;
}

sub logout($$) {
  my ($self,$r) = @_;
  my $debug = $r->dir_config("AuthCookieDebug") || 0;
  
  my ($auth_type, $auth_name) = ($r->auth_type, $r->auth_name);

view all matches for this distribution

Apache-AuthCookieLDAP

1 match


#===============================================================================
# F U N C T I O N   D E C L A R A T I O N S
#===============================================================================

sub _log_not_set($$);
sub _dir_config_var($$);
sub _dbi_config_vars($);
sub _now_year_month_day_hour_minute_second();
sub _percent_encode($);
sub _percent_decode($);

sub authen_cred($$\@);
sub authen_ses_key($$$);
sub group($$$);

#===============================================================================
# P A C K A G E   G L O B A L S
#===============================================================================

#===============================================================================

#-------------------------------------------------------------------------------
# _log_not_set -- Log that a particular authentication variable was not set.

sub _log_not_set($$)
{
	my( $r, $variable ) = @_;
	my $auth_name = $r->auth_name;
	$r->log_error( "Apache::AuthCookieLDAP: $variable not set for auth realm
$auth_name", $r->uri );
}

#-------------------------------------------------------------------------------
# _dir_config_var -- Get a particular authentication variable.

sub _dir_config_var($$)
{
	my( $r, $variable ) = @_;
	my $auth_name = $r->auth_name;
	return $r->dir_config( "$auth_name$variable" );
}

# _dbi_config_vars -- Gets the config variables from the dir_config and logs
# errors if required fields were not set, returns undef if any of the fields
# had errors or a hash of the values if they were all OK.  Takes a request
# object.

sub _dbi_config_vars($)
{
	my( $r ) = @_;

	my %c; # config variables hash


#-------------------------------------------------------------------------------
# _now_year_month_day_hour_minute_second -- Return a string with the time in
# this order separated by dashes.

sub _now_year_month_day_hour_minute_second()
{
	return sprintf '%04d-%02d-%02d-%02d-%02d-%02d', Today_and_Now;
}

#-------------------------------------------------------------------------------
# _percent_encode -- Percent-encode (like URI encoding) any non-alphanumberics
# in the supplied string.

sub _percent_encode($)
{
	my( $str ) = @_;
	$str =~ s/([^\w])/ uc sprintf '%%%02x', ord $1 /eg;
	return $str;
}

#-------------------------------------------------------------------------------
# _percent_decode -- Percent-decode (like URI decoding) any %XX sequences in
# the supplied string.

sub _percent_decode($)
{
	my( $str ) = @_;
	$str =~ s/%([0-9a-fA-F]{2})/ pack( "c",hex( $1 ) ) /ge;
	return $str;
}

#-------------------------------------------------------------------------------
# Take the credentials for a user and check that they match; if so, return
# a new session key for this user that can be stored in the cookie.
# If there is a problem, return a bogus session key.

sub authen_cred($$\@)
{
	my( $self, $r, @credentials ) = @_;

	my $auth_name = $r->auth_name;

}

#-------------------------------------------------------------------------------
# Take a session key and check that it is still valid; if so, return the user.

sub authen_ses_key($$$)
{
	my( $self, $r, $encrypted_session_key ) = @_;

	my $auth_name = $r->auth_name;

# This is taken from AuthCookieDBI and checks user groups from a database #
###########################################################################



sub group($$$)
{
        my( $self, $r, $groups ) = @_;
	my @groups = split(/\s+/, $groups);

        my $auth_name = $r->auth_name;

view all matches for this distribution

Apache-AuthCookiePAM

1 match


#===============================================================================
# F U N C T I O N   D E C L A R A T I O N S
#===============================================================================

sub _log_not_set($$);
sub _dir_config_var($$);
sub _config_vars($);
sub _now_year_month_day_hour_minute_second();
sub _percent_encode($);
sub _percent_decode($);

sub authen_cred($$\@);
sub authen_ses_key($$$);
sub group($$\@);

#===============================================================================
# P A C K A G E   G L O B A L S
#===============================================================================

#===============================================================================

#-------------------------------------------------------------------------------
# _log_not_set -- Log that a particular authentication variable was not set.

sub _log_not_set($$)
{
	my( $r, $variable ) = @_;
	my $auth_name; $auth_name = $r->auth_name;
	$r->log_error( "Apache::AuthCookiePAM: $variable not set for auth realm
$auth_name", $r->uri );
}

#-------------------------------------------------------------------------------
# _dir_config_var -- Get a particular authentication variable.

sub _dir_config_var($$)
{
	my( $r, $variable ) = @_;
	my $auth_name; $auth_name = $r->auth_name;
	return $r->dir_config( "$auth_name$variable" );
}

# _config_vars -- Gets the config variables from the dir_config and logs
# errors if required fields were not set, returns undef if any of the fields
# had errors or a hash of the values if they were all OK.  Takes a request
# object.

sub _config_vars($)
{
	my( $r ) = @_;

	my %c; # config variables hash


#-------------------------------------------------------------------------------
# _now_year_month_day_hour_minute_second -- Return a string with the time in
# this order separated by dashes.

sub _now_year_month_day_hour_minute_second()
{
	return sprintf '%04d-%02d-%02d-%02d-%02d-%02d', Today_and_Now;
}

#-------------------------------------------------------------------------------
# _percent_encode -- Percent-encode (like URI encoding) any non-alphanumberics
# in the supplied string.

sub _percent_encode($)
{
	my( $str ) = @_;
	$str =~ s/([^\w])/ uc sprintf '%%%02x', ord $1 /eg;
	return $str;
}

#-------------------------------------------------------------------------------
# _percent_decode -- Percent-decode (like URI decoding) any %XX sequences in
# the supplied string.

sub _percent_decode($)
{
	my( $str ) = @_;
	$str =~ s/%([0-9a-fA-F]{2})/ pack( "c",hex( $1 ) ) /ge;
	return $str;
}

#-------------------------------------------------------------------------------
# Take the credentials for a user and check that they match; if so, return
# a new session key for this user that can be stored in the cookie.
# If there is a problem, return a bogus session key.

sub authen_cred($$\@)
{
    my( $self, $r, @credentials ) ;
    ( $self, $r, @credentials ) = @_;

    my $auth_name; $auth_name = $r->auth_name;

}

#-------------------------------------------------------------------------------
# Take a session key and check that it is still valid; if so, return the user.

sub authen_ses_key($$$)
{
	my( $self, $r, $encrypted_session_key ) = @_;

	my $auth_name ; $auth_name = $r->auth_name;

view all matches for this distribution

Apache-AuthCookieURL

1 match

AuthCookieURL.pm view on Meta::CPAN


# Note -- should redirect without adding the session for URL-based logout?
# Might be smart to override this method so that the session can be marked as logged out
# in whatever database you are using

sub logout($$) {
  my ($self,$r) = @_;
  my $debug = $r->dir_config( DEBUG ) || 0;
  
  my ($auth_type, $auth_name) = ($r->auth_type, $r->auth_name);

view all matches for this distribution

Apache-AutoIndex

1 match

AutoIndex.pm view on Meta::CPAN

		}
	push @ {$cfg->{$key}}, $value;
return DECLINE_CMD if Apache->module('mod_autoindex.c');
}

sub DirectoryIndex($$$;*){
	my ($cfg, $parms, $files, $cfg_fh) = @_;
	for my $file (split /\s+/, $files){
		push @{$cfg->{indexfile}}, $file;
	}
return DECLINE_CMD if Apache->module('mod_dir.c');
}

sub IndexOptions($$$;*){
	my ($cfg, $parms, $directives, $cfg_fh) = @_;
	foreach (split /\s+/, $directives){
		my $option;
		(my $action, $_) = (lc $_) =~ /(\+|-)?(.*)/;

AutoIndex.pm view on Meta::CPAN

return DECLINE_CMD if Apache->module('mod_autoindex.c');
}

# e.g. DirectoryIndex index.html index.htm index.cgi 

sub AddDescription($$$;*){
    #this is not completely supported.  
    #Since I didn't take the time to fully check mod_autoindex.c behavior,
    #I just implemented this as simplt as I could.
    #It's in my TODO
    my ($cfg, $parms, $args, $cfg_fh) = @_;

AutoIndex.pm view on Meta::CPAN

	$file = patternize($file);
    $cfg->{desc}{$file} = $desc; 
return DECLINE_CMD if Apache->module('mod_autoindex.c');
}

sub IndexOrderDefault($$$$){
	my ($cfg, $parms, $order, $key) = @_;
	die "First Keyword must be Ascending or ending" unless ( $order =~ /^(de|a)scending$/i);
	die "First Keyword must be Name, Date, Size or Description" unless ( $key =~ /^(date|name|size|description)$/i);
	if ($key =~ /date/i){
		$key = 'M';

view all matches for this distribution

Apache-AxKit-Plugin-Session

1 match

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

# ____ End of save_reason ____



#==================
sub orig_get_reason($) {
#------------------
    my ($self) = @_;
    $self->debug(3,"======= orig_get_reason(".join(',',@_).")");
    my $r = Apache->request();
    my $auth_name = $r->auth_name || 'AxKitSession';

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

# ____ End of external_redirect ____



#====================
sub send_cookie($@) {
#--------------------
    my ($self, %settings) = @_;
    $self->debug(3,"======= send_cookie(".join(',',@_).")");
    my $r = Apache->request();
    my $auth_name = $r->auth_name || 'AxKitSession';

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN



# override this one to retrieve permissions from somewhere else.
# you still need to add a dummy 'require something' to httpd.conf
#========================
sub get_permissions($$) {
#------------------------
    my ($self, $r) = @_;
    my $reqs = $r->requires || return ();
    return map { [ split /\s+/, $_->{requirement}, 2 ] } @$reqs;
}
# ____ End of get_permissions ____


# handler for 'require user' directives
#=============
sub user($$) {
#-------------
    my ($self, $r, $args) = @_;
    $self->debug(3,"======= user(".join(',',@_).")");
    my $user = $r->connection->user;
    return OK if grep { $user eq $_ } split /\s+/, $args;

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

}
# ____ End of user ____

# Apache auto-configuration
#================================
sub initialize_url_sessions($@) {
#--------------------------------
    my ($self, $redirect_location) = @_;
    $redirect_location ||= '/redirect';

    # configure stuff

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN


# this part does the real work and won't be very useful for
# customization/subclassing.
# You may consider skipping to the 'require' handlers below.

sub makeVariableName($) { my $x = shift; $x =~ s/[^a-zA-Z0-9]/_/g; $x; }

sub save_reason($;$) {
    my ($self, $error_message) = @_;
    $self->debug(3,"--------- save_reason(".join(',',@_).")");
    my $session = Apache->request()->pnotes('SESSION') || return $self->orig_save_reason($error_message);

    if (!$error_message) {

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

        $$session{'auth_location'} = $r->uri;
        $$session{'auth_location'} .= '?'.$r->args if ($r->args);
    }
}

sub get_reason($) {
    my ($self) = @_;
    $self->debug(3,"--------- get_reason(".join(',',@_).")");
    my $session = Apache->request()->pnotes('SESSION') || return $self->orig_get_reason();

    $$session{'auth_reason'};
}

sub get_location($) {
    my ($self) = @_;
    $self->debug(3,"--------- get_location(".join(',',@_).")");
    my $session = Apache->request()->pnotes('SESSION') || return undef;

    $$session{'auth_location'};

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

    $self->debug(3,"--------- _cleanup_session(".join(',',@_).")");
    untie %{$session};
    undef %{$session};
}

sub _get_session_from_store($$;$) {
    my ($self, $r, $session_id) = @_;
    $self->debug(3,"--------- _get_session_from_store(".join(',',@_).")");
    my $auth_name = $r->auth_name || 'AxKitSession';
    my @now = localtime;
    my $session = {};

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

    };
    die "Session creation failed. Depending on which session module you use, make sure that directories $absdir, $absdir/locks or $absdir/counters, or database $dir exist and are writable. The error message was: $@" if $@ && !defined $session_id;
    return $session;
}

sub _get_session($$;$) {
    my ($self, $r, $session_id) = @_;
    my $auth_name = $r->auth_name || 'AxKitSession';
    $self->debug(3,"--------- _get_session(".join(',',@_).")");
    my $dir = $r->dir_config($auth_name.'Dir') || '/tmp/sessions';
    my $expire = ($r->dir_config($auth_name.'Expire') || 30) / 5 + 1; #/

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

}

# this is a NO-OP! Don't use this one (or ->login) directly,
# unless you have verified the credentials yourself or don't
# want user logins
sub authen_cred($$\@) {
    my ($self, $r, @credentials) = @_;
    $self->debug(3,"--------- authen_cred(".join(',',@_).")");
    my ($session, $err) = $self->_get_session($r);
    return (undef, $err) if $err;
    $$session{'auth_access_user'} = $credentials[0] if defined $credentials[0];
    $r->pnotes('SESSION',$session);
    return $$session{'_session_id'};
}

sub authen_ses_key($$$) {
    my ($self, $r, $session_id) = @_;
    $self->debug(3,"--------- authen_ses_key(".join(',',@_).")");
    my ($session, $err) = $self->_get_session($r, $session_id);
    return (undef, $err) if $err;
    return ($session_id eq $$session{'_session_id'})?$$session{'auth_access_user'}:undef;
}

sub logout($$) {
    my ($self) = shift;
    my ($r) = @_;
    $self->debug(3,"--------- logout(".join(',',$self,@_).")");
    my $session = $r->pnotes('SESSION');
    eval {

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

    return $self->orig_logout(@_);
}

# 'require' handlers

sub subrequest($$) {
    my ($self, $r) = @_;
    $self->debug(3,"--------- subrequest(".join(',',@_).")");
    return ($r->is_initial_req?FORBIDDEN:OK);
}

sub group($$) {
    my ($self, $r, $args) = @_;
    $self->debug(3,"--------- group(".join(',',@_).")");
    my $session = $r->pnotes('SESSION');

    my $groups = $$session{'auth_access_group'};

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

        return OK if exists $$groups{$_};
    }
    return FORBIDDEN;
}

sub level($$) {
    my ($self, $r, $args) = @_;
    $self->debug(3,"--------- level(".join(',',@_).")");
    my $session = $r->pnotes('SESSION');

    if (exists $$session{'auth_access_level'}) {
        return OK if ($$session{'auth_user_level'} >= $args);
    }
    return FORBIDDEN;
}

sub combined($$) {
    my ($self, $r, $args) = @_;
    $self->debug(3,"--------- combined(".join(',',@_).")");
    my ($requirement, $arg);
    while ($args =~ m/\s*(.*?)\s+("(?:.*?(?:\\\\|\\"))*.*?"(?:\s|$)|[^" \t\r\n].*?(?:\s|$))/g) {
        ($requirement, $arg) = ($1, $2);

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

        return FORBIDDEN if $rc != OK;
    }
    return OK;
}

sub alternate($$) {
    my ($self, $r, $args) = @_;
    $self->debug(3,"--------- alternate(".join(',',@_).")");
    my ($requirement, $arg);
    while ($args =~ m/\s*(.*?)\s+("(?:.*?(?:\\\\|\\"))*.*?"(?:\s|$)|[^" \t\r\n].*?(?:\s|$))/g) {
        ($requirement, $arg) = ($1, $2);

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

        return OK if $rc == OK;
    }
    return FORBIDDEN;
}

sub not($$) {
    my ($self, $r, $args) = @_;
    $self->debug(3,"--------- not(".join(',',@_).")");
    my ($requirement, $arg) = split /\s+/, $args, 2;
    $requirement = makeVariableName($requirement);
    no strict 'refs';

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

    no strict 'refs';
    my $sub = "pack_requirement_".makeVariableName($$args[1][0]);
    return $$args[1][0].' '.$self->$sub($$args[1]);
}

sub set_permissions($$@) {
    my ($self, $r, @perms) = @_;
    @perms = map { 'require '.$_->[0].' '.$_->[1]."\n" } @perms;
    if ($r->uri =~ m/#[^\/]*$/) {
        push @perms, "SetHandler perl-script\n";
        push @perms, "PerlHandler \"sub { &Apache::Constants::NOT_FOUND; }\"\n";

lib/Apache/AxKit/Plugin/Session.pm view on Meta::CPAN

    }
}

# interfaces for the taglib

sub get_permission_set($$) {
    my ($self, $r) = @_;
    my @rc = ();
    foreach my $req ($self->get_permissions($r)) {
        $$req[1] = '' unless defined $$req[1];
        my $sub = 'unpack_requirement_'.makeVariableName($$req[0]);
        push @rc, $self->$sub(@$req);
    }
    return @rc;
}

sub set_permission_set($$@) {
    my ($self, $r, @reqs) = @_;
    my @rc;
    my $req;
    foreach my $req (@reqs) {
        my $sub = "pack_requirement_".makeVariableName($$req[0]);

view all matches for this distribution

Apache-CVS

2 results

CVS.pm view on Meta::CPAN

                               $query{'asc'});
        }
    }
}

sub handler($$) {

    my ($self, $request) = @_;

    delete $ENV{'PATH'};

view all matches for this distribution

Apache-Centipaid

2 results

Centipaid.pm view on Meta::CPAN


use strict;

$Apache::Centipaid::VERSION = '1.3.1';

sub need_to_pay($) {
	my $r = shift(@_);
	my $payto = $r->dir_config("acct") || 0;
	my $amount = $r->dir_config("amount") || 0;
	my $duration = $r->dir_config("duration") || 0;
	my $uri =  $r->uri;

view all matches for this distribution

Apache-ClearSilver

1 match

lib/Apache/ClearSilver.pm view on Meta::CPAN

    } elsif (ref $val eq '') {
        $hdf->setValue($key, $val);
    }
}

sub HDFLoadPath($$@) {
    my ($cfg, $params, $arg) = @_;
    my $paths = $cfg->{HDFLoadPath} ||= [];
    push @$paths, $arg;
}

sub HDFFile($$@) {
    my ($cfg, $params, $arg) = @_;
    my $paths = $cfg->{HDFFile} ||= [];
    push @$paths, $arg;
}

sub HDFSetValue($$$$) {
    my ($cfg, $parms, $name, $value) = @_;
    $cfg->{HDFValue}->{$name} = $value;
}

sub CSContentType($$$) {
    my ($cfg, $params, $arg) = @_;
    $cfg->{CSContentType} = $arg;
}

1;

view all matches for this distribution

Apache-CryptHash

1 match

CryptHash.pm view on Meta::CPAN

  use vars qw($VERSION);
  $VERSION = do { my @r = (q$Revision: 3.03 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
}


sub init() {
  my ($proto, $crypt) = @_;
  my $class = ref($proto) || $proto;
  my $self  = {};
  $self->{NAME} = 'Secret';		# default header name
  $self->{CRYPT} = $crypt || do {	# default password is hostname

CryptHash.pm view on Meta::CPAN

# md5_hex
#
# input:	string
# returns:	md5 hex hash of string
#
sub md5_hex($$) {
  my ($self, $string) = @_;
  return Crypt::CapnMidNite->new->md5_hex($string);
}

#####################################################
# md5_b64
#
# input:        string
# returns:      md5 base 64 of string
#
sub md5_b64($$) {
  my ($self, $string) = @_;
  return Crypt::CapnMidNite->new->md5_base64($string);
}

#####################################################

CryptHash.pm view on Meta::CPAN

#  (optional)	pointer to keys 	# \@k
#			(array) of values to include in MAC
#			these must be invarient and will 
#			fail to decrypt otherwise
#
sub encode($$$) {
  my ( $self, $state, $k ) = @_;	# get my self
  &_MAC($self, $state, $k, 'generate');	# add MAC to state
  my $cipher = Crypt::CapnMidNite->new_md5_rc4($self->{CRYPT});
  my %s = %$state;
  foreach (keys %s) {

view all matches for this distribution

Apache-CustomKeywords

1 match

lib/Apache/CustomKeywords.pm view on Meta::CPAN

$MSN_URL = 'http://auto.search.msn.com/response.asp';
$MSN_KEY = 'MT';

__PACKAGE__->bootstrap($VERSION) if $ENV{MOD_PERL};

sub handler($$) {
    my($class, $r) = @_;
    if ($r->proxyreq) {
	my $uri = $r->uri;
	if ($uri =~ /^$MSN_URL/) {
	    my $location = $class->convert_query($r);

lib/Apache/CustomKeywords.pm view on Meta::CPAN

    my($class, $r) = @_;
    my %args = $r->args;
    return $args{$MSN_KEY};
}

sub CustomKeyword($$$$) {
    my($cfg, $parms, $arg1, $arg2) = @_;
    $cfg->{CustomKeywordsDefault} ||= $arg1;
    $cfg->{CustomKeywords} ||= {};
    $cfg->{CustomKeywords}->{$arg1} = $arg2;
}

view all matches for this distribution

Apache-DBI-Cache

12 results

t/001cache.t view on Meta::CPAN

use strict;
use Test::More tests => 16;
use Test::Deep;

sub n($) {my @c=caller; $c[1].'('.$c[2].'): '.$_[0];}

BEGIN{$ENV{APACHE_DBI_CACHE_ENVPATH}="t/dbenv";}

BEGIN { use_ok('Apache::DBI::Cache') };

view all matches for this distribution

Apache-DBILogger

1 match

DBILogger.pm view on Meta::CPAN

use Date::Format;

$Apache::DBILogger::revision = sprintf("%d.%02d", q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/o);
	$Apache::DBILogger::VERSION = "0.93";

sub reconnect($$) {
	my ($dbhref, $r) = @_;

	$$dbhref->disconnect;

	$r->log_error("Reconnecting to DBI server");

view all matches for this distribution

Apache-Description

1 match

    croak "impossible to open $filename in read-write : $!";
  }
}

## add a description
sub add($$){
  my ($self, $file, $desc) = @_;

  print $fh qq/AddDescription "$desc" "$file"\n/;
}

## remove an entry
## this operation is "expensive" : two files are created, and I
## need to parse the whole file.
## if there are more than one directive for the file wanted, they are
## both deleted.
sub remove($) {
  my ($self, $wanted) = @_;
  my $fd;

  $fh->setpos(0);
  $fd = IO::File->new(">/tmp/htaccess.$$");

  }

  return \%hash;
}

sub get($) {
  my $self   = shift;
  my $wanted = shift;
  my $ret    = undef;

  croak "no file descriptor available" unless defined $fh;


sub rename {
  print qq/Not implemented yet\n/;
}

sub ispresent($) {
  my $self = shift;
  my $file = shift;

  return $self->get($file) ? 1 : 0;
}

view all matches for this distribution

Apache-GD-Thumbnail

1 match

Thumbnail.pm view on Meta::CPAN

    my ($thumb,$x,$y)=Image::GD::Thumbnail::create($src,$MaxSize);
    $r->print($thumb->jpeg);
    return OK;
}

sub _conf($)
{
    my $arg=shift;
    return eval("\$".__PACKAGE__."::".$arg);
}

view all matches for this distribution

Apache-GDGraph

1 match

lib/Apache/GD/Graph.pm view on Meta::CPAN

	gdTransparent	=> gdTransparent
};

# Sub prototypes:

sub init();
sub handler ($);
sub parse ($;$);
sub arrayCheck ($$);
sub error ($);
sub makeDir ($);

lib/Apache/GD/Graph.pm view on Meta::CPAN


# init()
#
# Called only once on the first request received. May be called once per child
# in Apache.
sub init() {
# Set the GD::Text fontpath.
	GD::Text->font_path ($r->dir_config('TTFFontPath') || TTF_FONT_PATH);

	$cache_size = $r->dir_config('CacheSize');

view all matches for this distribution

Apache-Gateway

1 match

user agent is modified for seach request; it is not constant and is
probably not shareable.

=cut

sub new($;$) {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    my $self = {};
    $self->{UA} = @_ ? shift : new LWP::UserAgent,


Get/set the user agent.

=cut

sub user_agent($;$) {
    my $self = shift;
    if (@_) { $self->{UA} = shift }
    return $self->{UA};
}

Get/set the Apache request currently being gatewayed.  To send the
request, see the send_request method.

=cut

sub request($;$) {
    my $self = shift;
    if (@_) { $self->{REQUEST} = shift }
    return $self->{REQUEST};
}


# Get/set the cached configuration information and current run state.
# This very low-level method is for hackers only.  This API might
# change.

sub _config($;$) {
    my $self = shift;
    if (@_) { $self->{CONFIG} = shift }
    return $self->{CONFIG};
}

Get/set the configuration information for this gateway location.  Can
be overridden to provide dynamic per location information

=cut

sub location_config($;$) {
    my $self = shift;
    my $config_file = $self->{REQUEST}->dir_config('GatewayConfig');
    if (@_) { $self->{CONFIG}{$config_file} = shift }
    return $self->{CONFIG}{$config_file};
}

#  mux sites list = { START_INDEX => start index of round robin,
#		      SITE => [ site, site, ... ] }

# This structure is subject to change.  Because it contains state
# information, it is per object and cannot be shared.
sub _init_config_file($) {
    my $self = shift;
    my $r = $self->{REQUEST};
    my $config = $self->{CONFIG};
    my $config_file = $r->dir_config('GatewayConfig');
    unless ($config_file) {


Clear request headers in $r in preparation for a redirect.

=cut

sub clear_headers_for_redirect($) {
    my $r = shift;
    # Some of this should be done with Apache::Tie when it is working.
    $r->header_out('Content-Length' => undef); # should use tie
    $r->status(HTTP::Status::RC_OK);


Return semicanonicalized server URL (without trailing slash).

=cut

sub canonicalized_server_URL($$$) {
    my($scheme, $host, $port) = @_;
    my $server = lc($scheme . '://' . $host);
    if(defined $port and exists $default_port{$scheme}
       and $port != $default_port{$scheme}) {
	$server .= ':' . $port;

The "server name" is defined as the leading scheme://authority portion
of the URL.

=cut

sub server_name_from_URL($$) {
    my ($r, $url) = @_;
    $url = Apache::URI->parse($r, $url) unless ref $url;
    return canonicalized_server_URL($url->scheme, $url->hostname, $url->port);
}

scheme://authority portion of the URL.  Currently assumes server
access is via HTTP.

=cut

sub server_name($) {
    my $r = shift;
    return canonicalized_server_URL('http', $r->server->server_hostname,
				    $r->server->port);
}

mirror during the two hours of the year when one server is in Daylight
Savings Time and the other is not.

=cut

sub diff_TZ($$) {
    my($mirror_TZ, $origin_TZ) = @_;

    return 0 if $origin_TZ eq $mirror_TZ; # no need to do anything

    # Use Thu Jan 01 00:00:00 GMT 1998 as a reference time.  No

Eventually, options should be provided to control hostname suppression
and comment customization.

=cut

sub update_via_header_field($$) {
    my($self, $response) = @_;
    my $r = $self->{REQUEST};

    # Set protocol.
    my $hop = $response->protocol;

The only tricky item is the Content-Type header, which needs special
handling.

=cut

sub copy_header_to_Apache_request($$) {
    my($r, $header) = @_;

    # Apache might already know the proper content type, e.g., by use
    # of a ForceType directive.  If so, try not to override it.  Else,
    # the type needs to be set explicitly with the Apache request's


    # Copy headers to Apache request (in "Good Practice" order).
    $header->scan(sub {$r->header_out(@_);});
}

sub print_headers($$$) {
    my ($self, $response, $allow_abort) = @_;
    my $r = $self->{REQUEST};
    my $site = $self->{SITE};
    my $path = $self->{GW_PATH};

C<internal_redirect_handler> does not provide hooks for detecting and
recovering from errors.

=cut

sub redirect($$) {
    my ($self, $allow_abort) = @_;

    my $r = $self->{REQUEST};
    my $ua = $self->{UA};
    my $site = $self->{SITE};

Get/set the site tried.  Can be used to determine which upstream
server actually fields a request.

=cut

sub site($;$) {
    my $self = shift;
    if (@_) { $self->{SITE} = shift }
    return $self->{SITE};
}

That's not B<mod_perl>'s fault--B<Apache> source would need to be
modified to support such a hook.

=cut

sub try_URI($$) {
    my ($self, $allow_abort) = @_;
    clear_headers_for_redirect($self->{REQUEST});
    $self->redirect($allow_abort);
}

Abortion is needed because only one request can be allowed to run to
completion and produce a message body.

=cut

sub try_sites($$@) {
    my ($self, $allow_last_site_abort, @site) = @_;

    my $r = $self->{REQUEST};

    # Try all but last site, aborting each attempt on error.

		  || $r->connection->aborted);
    }
}

# Set up the user agent for this particular request.
sub _init_ua($) {
    my $self = shift;
    my $r = $self->{REQUEST};
    my $ua = $self->{UA};
    $ua->from($r->server->server_admin);
    $ua->agent($r->header_in('User-Agent'));

}

# Set $self->{GW_PATH} to the portion of the path relative to
# GatewayRoot.  This is also the path which is appended to the URIs of
# the upstream servers.
sub _init_path($) {
    my $self = shift;
    my $r = $self->{REQUEST};

    # epath = $gw_root . $gw_path
    my $gw_root = $self->location_config->{ROOT};


    $self->{GW_PATH} = $gw_path; # succeeded
    return 1;
}

sub _init_request($) {
    my $self = shift;
    $self->_init_config_file	or return;
    $self->_init_ua		or return;
    $self->_init_path		or return;
    return 1;			# succeeded

the GatewayConfig file in order and returns the sites in the first
section matched.

=cut

sub site_list($) {
    my $self = shift;
    my $location_conf = $self->location_config;
    my $gw_path = $self->{GW_PATH};
    foreach my $entry (@{$location_conf->{LOCATION}}) {
	if($gw_path =~ /$entry->{PATTERN}/) {

Send the Apache request to the upstream server.  Optionally sets it
first.

=cut

sub send_request($;$) {
    my $self = shift;
    if (@_) { $self->{REQUEST} = shift }
    $self->_init_request or return;
    $self->try_sites(0, $self->site_list);
    return 1;			# succeeded

view all matches for this distribution

Apache-Handlers

1 match