^sub \w+\( results from the CPAN

# BEGIN helper functions

###############
#  _basename  #  Poor man's implementation, to avoid including File::Basename
###############
sub _basename($) {
    my $f = shift;

    $f =~ m!/([^/]+)$!
      and return $1;
    return $f;
}

##################
#  _stack_trace  #  returns pretty stack trace
##################
sub _stack_trace() {
    my @levels;

    # Get a full callback history, first-is-first (that is, the
    # main script is first, instead of the usual most-recent-first).
    # @levels will be a LoH, an array containing hashrefs.



################
#  maintainer  #  returns nicely formatted HREF and address of maintainer
################
sub maintainer() {
    my $real_name = "";
    my $just_mail = $Maintainer;

    # Address is of the form "Foo Bar <fubar@some.where>" ?
    if ($just_mail =~ s/^(.*)<(.*)>(.*)$/$2/) {

# BEGIN main notification function

############
#  notify  #  Gets called on END, to send email to maintainer
############
sub notify($@) {
    my $subject = shift;

    eval {
	my %env = %ENV;
	local %ENV;

# BEGIN auxiliary function for our caller to die _before_ emitting headers

##############
#  http_die  #  Called if we see an error _before_ emitting HTTP headers.
##############
sub http_die($@) {
    my $status   = shift;		# Something like "400 Bad Request"
    # Or maybe it's '--no-mail' ?  If so, $status is the next one
    if ($status =~ /^--?no-?(mail|alert)$/) {
	$SIG{__WARN__} = sub {
	    printf STDERR "[%s - %s]: DIED: %s\n", $ME, scalar localtime, @_;

      unless $DEBUG_SENDMAIL;
};
$SIG{__WARN__} = \&_warn;

# (helper function for END and signal handlers
sub check_warnings(;$) {
    if (@warnings) {
	my $msg = "The following warnings were detected:";

	# Called with arguments?  Must be a signal.
	if (@_)		{ $msg = "Script was aborted by SIG$_[0]!  $msg"    }



################
################  FATAL ERRORS.  This gets called on any 'die'.
################
sub _die($) {
    my $msg = shift;

    # Called inside an eval?  Pass it on.  This lets caller do things safely.
    die $msg if $^S or not defined $^S;

# BEGIN caller-accessible functions (not yet exported)

#######################
#  emit_http_headers  #  Caller can tell us when to emit 'Status', etc
#######################
sub emit_http_headers($) {
    $Emit_HTTP_Headers = 0 + $_[0];
}

########################
#  extra_html_headers  #  Caller can give us stylesheets, etc
########################
sub extra_html_headers(@) {
    @Extra_HTML_Headers = @_;
}


#########################
#  custom_browser_text  #  Caller can give us a custom text to display
#########################
sub custom_browser_text($) {
    $Browser_Text = shift;
}


# END   caller-accessible functions (not yet exported)

view all matches for this distribution

CGI-Application-Emulate-PSGI

1 match

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

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

#line 471

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

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

view all matches for this distribution

CGI-Application-PSGI

2 results

    $default_object ||= $default_class->new;
    return $default_object;
}

my $import_called = 0;
sub import() {
    $import_called = 1;
    my $class = (grep /^-base$/i, @_) 
    ? scalar(caller)
    : $_[0];
    if (not defined $default_class) {

        $caller =~ s/.*:://;
        croak "Too late to call $caller()"
    }
}

sub find_my_self() {
    my $self = ref($_[0]) eq $default_class
    ? splice(@_, 0, 1)
    : default_object();
    return $self, @_;
}

sub blocks() {
    (my ($self), @_) = find_my_self(@_);

    croak "Invalid arguments passed to 'blocks'"
      if @_ > 1;
    croak sprintf("'%s' is invalid argument to blocks()", shift(@_))

    }

    return (@blocks);
}

sub next_block() {
    (my ($self), @_) = find_my_self(@_);
    my $list = $self->_next_list;
    if (@$list == 0) {
        $list = [@{$self->block_list}, undef];
        $self->_next_list($list);

        $block->run_filters;
    }
    return $block;
}

sub first_block() {
    (my ($self), @_) = find_my_self(@_);
    $self->_next_list([]);
    $self->next_block;
}

sub filters_delay() {
    (my ($self), @_) = find_my_self(@_);
    $self->_filters_delay(defined $_[0] ? shift : 1);
}

sub no_diag_on_only() {
    (my ($self), @_) = find_my_self(@_);
    $self->_no_diag_on_only(defined $_[0] ? shift : 1);
}

sub delimiters() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    my ($block_delimiter, $data_delimiter) = @_;
    $block_delimiter ||= $self->block_delim_default;
    $data_delimiter ||= $self->data_delim_default;
    $self->block_delim($block_delimiter);
    $self->data_delim($data_delimiter);
    return $self;
}

sub spec_file() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_file(shift);
    return $self;
}

sub spec_string() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_string(shift);
    return $self;
}

sub filters() {
    (my ($self), @_) = find_my_self(@_);
    if (ref($_[0]) eq 'HASH') {
        $self->_filters_map(shift);
    }
    else {

        push @$filters, @_;
    }
    return $self;
}

sub filter_arguments() {
    $Test::Base::Filter::arguments;
}

sub have_text_diff {
    eval { require Text::Diff; 1 } &&
        $Text::Diff::VERSION >= 0.35 &&
        $Algorithm::Diff::VERSION >= 1.15;
}

sub is($$;$) {
    (my ($self), @_) = find_my_self(@_);
    my ($actual, $expected, $name) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    if ($ENV{TEST_SHOW_NO_DIFFS} or
         not defined $actual or

        ok $actual eq $expected,
           $name . "\n" . Text::Diff::diff(\$expected, \$actual);
    }
}

sub run(&;$) {
    (my ($self), @_) = find_my_self(@_);
    my $callback = shift;
    for my $block (@{$self->block_list}) {
        $block->run_filters unless $block->is_filtered;
        &{$callback}($block);


sub END {
    run_compare() unless $Have_Plan or $DIED or not $import_called;
}

sub run_compare() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

            is($block->$x, $block->$y, $block->name ? $block->name : ());
        }
    }
}

sub run_is() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

           $block->name ? $block->name : ()
          );
    }
}

sub run_is_deeply() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and exists($block->{$y});

           $block->name ? $block->name : ()
          );
    }
}

sub run_like() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

             $block->name ? $block->name : ()
            );
    }
}

sub run_unlike() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

               $block->name ? $block->name : ()
              );
    }
}

sub skip_all_unless_require() {
    (my ($self), @_) = find_my_self(@_);
    my $module = shift;
    eval "require $module; 1"
        or Test::More::plan(
            skip_all => "$module failed to load"
        );
}

sub is_deep() {
    (my ($self), @_) = find_my_self(@_);
    require Test::Deep;
    Test::Deep::cmp_deeply(@_);
}

sub run_is_deep() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and exists($block->{$y});

        };
    }
    return $spec;
}

sub _strict_warnings() {
    require Filter::Util::Call;
    my $done = 0;
    Filter::Util::Call::filter_add(
        sub {
            return 0 if $done;

            $done = 1;
        }
    );
}

sub tie_output() {
    my $handle = shift;
    die "No buffer to tie" unless @_;
    tie $handle, 'Test::Base::Handle', $_[0];
}

    $ENV{TEST_SHOW_NO_DIFFS} = 1;
}

package Test::Base::Handle;

sub TIEHANDLE() {
    my $class = shift;
    bless \ $_[0], $class;
}

sub PRINT {


sub AUTOLOAD {
    return;
}

sub block_accessor() {
    my $accessor = shift;
    no strict 'refs';
    return if defined &$accessor;
    *$accessor = sub {
        my $self = shift;

view all matches for this distribution

CGI-Application-Plugin-Authentication

1 match

t/02_config.t view on Meta::CPAN

use lib qw(t);

###############################################################################
# FAKE our own versions of these methods; newer Perls fail when we use the
# versions from Test::Exception, throwing "Bizarre copy of HASH in sassign...".
sub lives_ok(&;$) {
    my ($coderef, $name) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my $rc = eval { $coderef->() };
    ok !$@, $name;
}
sub throws_ok(&$;$) {
    my ($coderef, $expecting, $name) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my $rc = eval { $coderef->() };
    like $@, $expecting, $name;
}

view all matches for this distribution

CGI-Application-Plugin-Cache-Adaptive

2 results

    $default_object ||= $default_class->new;
    return $default_object;
}

my $import_called = 0;
sub import() {
    $import_called = 1;
    my $class = (grep /^-base$/i, @_) 
    ? scalar(caller)
    : $_[0];
    if (not defined $default_class) {

        $caller =~ s/.*:://;
        croak "Too late to call $caller()"
    }
}

sub find_my_self() {
    my $self = ref($_[0]) eq $default_class
    ? splice(@_, 0, 1)
    : default_object();
    return $self, @_;
}

sub blocks() {
    (my ($self), @_) = find_my_self(@_);

    croak "Invalid arguments passed to 'blocks'"
      if @_ > 1;
    croak sprintf("'%s' is invalid argument to blocks()", shift(@_))

    }

    return (@blocks);
}

sub next_block() {
    (my ($self), @_) = find_my_self(@_);
    my $list = $self->_next_list;
    if (@$list == 0) {
        $list = [@{$self->block_list}, undef];
        $self->_next_list($list);

        $block->run_filters;
    }
    return $block;
}

sub first_block() {
    (my ($self), @_) = find_my_self(@_);
    $self->_next_list([]);
    $self->next_block;
}

sub filters_delay() {
    (my ($self), @_) = find_my_self(@_);
    $self->_filters_delay(defined $_[0] ? shift : 1);
}

sub no_diag_on_only() {
    (my ($self), @_) = find_my_self(@_);
    $self->_no_diag_on_only(defined $_[0] ? shift : 1);
}

sub delimiters() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    my ($block_delimiter, $data_delimiter) = @_;
    $block_delimiter ||= $self->block_delim_default;
    $data_delimiter ||= $self->data_delim_default;
    $self->block_delim($block_delimiter);
    $self->data_delim($data_delimiter);
    return $self;
}

sub spec_file() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_file(shift);
    return $self;
}

sub spec_string() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_string(shift);
    return $self;
}

sub filters() {
    (my ($self), @_) = find_my_self(@_);
    if (ref($_[0]) eq 'HASH') {
        $self->_filters_map(shift);
    }
    else {

        push @$filters, @_;
    }
    return $self;
}

sub filter_arguments() {
    $Test::Base::Filter::arguments;
}

sub have_text_diff {
    eval { require Text::Diff; 1 } &&
        $Text::Diff::VERSION >= 0.35 &&
        $Algorithm::Diff::VERSION >= 1.15;
}

sub is($$;$) {
    (my ($self), @_) = find_my_self(@_);
    my ($actual, $expected, $name) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    if ($ENV{TEST_SHOW_NO_DIFFS} or
         not defined $actual or

        ok $actual eq $expected,
           $name . "\n" . Text::Diff::diff(\$expected, \$actual);
    }
}

sub run(&;$) {
    (my ($self), @_) = find_my_self(@_);
    my $callback = shift;
    for my $block (@{$self->block_list}) {
        $block->run_filters unless $block->is_filtered;
        &{$callback}($block);


sub END {
    run_compare() unless $Have_Plan or $DIED or not $import_called;
}

sub run_compare() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

            is($block->$x, $block->$y, $block->name ? $block->name : ());
        }
    }
}

sub run_is() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

           $block->name ? $block->name : ()
          );
    }
}

sub run_is_deeply() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and exists($block->{$y});

           $block->name ? $block->name : ()
          );
    }
}

sub run_like() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

             $block->name ? $block->name : ()
            );
    }
}

sub run_unlike() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

        };
    }
    return $spec;
}

sub _strict_warnings() {
    require Filter::Util::Call;
    my $done = 0;
    Filter::Util::Call::filter_add(
        sub {
            return 0 if $done;

            $done = 1;
        }
    );
}

sub tie_output() {
    my $handle = shift;
    die "No buffer to tie" unless @_;
    tie $handle, 'Test::Base::Handle', $_[0];
}

    $ENV{TEST_SHOW_NO_DIFFS} = 1;
}

package Test::Base::Handle;

sub TIEHANDLE() {
    my $class = shift;
    bless \ $_[0], $class;
}

sub PRINT {


sub AUTOLOAD {
    return;
}

sub block_accessor() {
    my $accessor = shift;
    no strict 'refs';
    return if defined &$accessor;
    *$accessor = sub {
        my $self = shift;

view all matches for this distribution

CGI-Application-Structured-Tools

1 match

lib/CGI/Application/Structured/Tools/templates/create_controller.pl view on Meta::CPAN

# user supplies these:
#
my $new_module;
my $result = GetOptions( "name=s" => \$new_module, );

sub usage()
{
	print "usage:\n";
	print "  cd MyApp\n";
	print "  perl script/create_controller.pl --name=MyMod\n";
}

view all matches for this distribution

CGI-AuthRegister

2 results

AuthRegister.pm view on Meta::CPAN

$Email_bcc  = ''; # Example: $SiteId.' Bcc <vlado@dnlp.ca>';

$Sendmail = "/usr/lib/sendmail"; # Sendmail with full path

# Some function prototypes
sub putfile($@);

########################################################################
# Section: Configuration
# sets site id as the base directory name; imports configuration.pl if exists
sub import_dir_and_config {

AuthRegister.pm view on Meta::CPAN

    local $_ = shift;
    s/x([0-9A-Fa-f][0-9A-Fa-f])/pack("c",hex($1))/ge;
    return $_;
}

sub encodeuri($) {
  local $_ = shift;
  s/[^-A-Za-z0-9_.~:\/?=]/"%".uc unpack("H2",$1)/ge;
  return $_;
}

# Prepare for HTML display by quoting meta characters.
sub htmlquote($) { local $_ = shift; s/&/&amp;/g; s/</&lt;/g; return $_; }

sub emailcheckok {
    my $email = shift;
    if ($email =~ /^[a-zA-Z][\w\.+-]*[a-zA-Z0-9+-]@
         [a-zA-Z0-9][\w\.-]*[a-zA-Z0-9]\.[a-zA-Z][a-zA-Z\.]*[a-zA-Z]$/x)

AuthRegister.pm view on Meta::CPAN

    return '' if $n < 1;
    my @r = map { $_[rand($#_+1)] } (1..$n);
    return join('',@r);
}

sub putfile($@) {
    my $f = shift; local *F;
    if (!open(F, ">$f")) { $Error.="325-ERR:Cannot write ($f):$!\n"; return; }
    for (@_) { print F } close(F);
}

sub getfile($) {
    my $f = shift; local *F;
    if (!open(F, "<$f")) {
      $Error.="ERR-1099:getfile:cannot open $f:$!"; return; }
    my @r = <F>; close(F);
    return wantarray ? @r : join ('', @r);

view all matches for this distribution

CGI-Cookie-XS

2 results

    $default_object ||= $default_class->new;
    return $default_object;
}

my $import_called = 0;
sub import() {
    $import_called = 1;
    my $class = (grep /^-base$/i, @_) 
    ? scalar(caller)
    : $_[0];
    if (not defined $default_class) {

        $caller =~ s/.*:://;
        croak "Too late to call $caller()"
    }
}

sub find_my_self() {
    my $self = ref($_[0]) eq $default_class
    ? splice(@_, 0, 1)
    : default_object();
    return $self, @_;
}

sub blocks() {
    (my ($self), @_) = find_my_self(@_);

    croak "Invalid arguments passed to 'blocks'"
      if @_ > 1;
    croak sprintf("'%s' is invalid argument to blocks()", shift(@_))

    }

    return (@blocks);
}

sub next_block() {
    (my ($self), @_) = find_my_self(@_);
    my $list = $self->_next_list;
    if (@$list == 0) {
        $list = [@{$self->block_list}, undef];
        $self->_next_list($list);

        $block->run_filters;
    }
    return $block;
}

sub first_block() {
    (my ($self), @_) = find_my_self(@_);
    $self->_next_list([]);
    $self->next_block;
}

sub filters_delay() {
    (my ($self), @_) = find_my_self(@_);
    $self->_filters_delay(defined $_[0] ? shift : 1);
}

sub no_diag_on_only() {
    (my ($self), @_) = find_my_self(@_);
    $self->_no_diag_on_only(defined $_[0] ? shift : 1);
}

sub delimiters() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    my ($block_delimiter, $data_delimiter) = @_;
    $block_delimiter ||= $self->block_delim_default;
    $data_delimiter ||= $self->data_delim_default;
    $self->block_delim($block_delimiter);
    $self->data_delim($data_delimiter);
    return $self;
}

sub spec_file() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_file(shift);
    return $self;
}

sub spec_string() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_string(shift);
    return $self;
}

sub filters() {
    (my ($self), @_) = find_my_self(@_);
    if (ref($_[0]) eq 'HASH') {
        $self->_filters_map(shift);
    }
    else {

        push @$filters, @_;
    }
    return $self;
}

sub filter_arguments() {
    $Test::Base::Filter::arguments;
}

sub have_text_diff {
    eval { require Text::Diff; 1 } &&
        $Text::Diff::VERSION >= 0.35 &&
        $Algorithm::Diff::VERSION >= 1.15;
}

sub is($$;$) {
    (my ($self), @_) = find_my_self(@_);
    my ($actual, $expected, $name) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    if ($ENV{TEST_SHOW_NO_DIFFS} or
         not defined $actual or

        ok $actual eq $expected,
           $name . "\n" . Text::Diff::diff(\$expected, \$actual);
    }
}

sub run(&;$) {
    (my ($self), @_) = find_my_self(@_);
    my $callback = shift;
    for my $block (@{$self->block_list}) {
        $block->run_filters unless $block->is_filtered;
        &{$callback}($block);


sub END {
    run_compare() unless $Have_Plan or $DIED or not $import_called;
}

sub run_compare() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

            is($block->$x, $block->$y, $block->name ? $block->name : ());
        }
    }
}

sub run_is() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

           $block->name ? $block->name : ()
          );
    }
}

sub run_is_deeply() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and exists($block->{$y});

           $block->name ? $block->name : ()
          );
    }
}

sub run_like() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

             $block->name ? $block->name : ()
            );
    }
}

sub run_unlike() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

        };
    }
    return $spec;
}

sub _strict_warnings() {
    require Filter::Util::Call;
    my $done = 0;
    Filter::Util::Call::filter_add(
        sub {
            return 0 if $done;

            $done = 1;
        }
    );
}

sub tie_output() {
    my $handle = shift;
    die "No buffer to tie" unless @_;
    tie $handle, 'Test::Base::Handle', $_[0];
}

    $ENV{TEST_SHOW_NO_DIFFS} = 1;
}

package Test::Base::Handle;

sub TIEHANDLE() {
    my $class = shift;
    bless \ $_[0], $class;
}

sub PRINT {


sub AUTOLOAD {
    return;
}

sub block_accessor() {
    my $accessor = shift;
    no strict 'refs';
    return if defined &$accessor;
    *$accessor = sub {
        my $self = shift;

view all matches for this distribution

CGI-Embedder

1 match

# Ñàìè òýãè <? è ?>, êîíå÷íî, óäàëÿþòñÿ. Åñëè çàòåì ïðîðàáîòàòü ðåçóëüòàò 
# eval-îì, íàïå÷àòàåòñÿ "ðàçâåðíóòûé" øàáëîí â ÷èñòîì âèäå. Åñëè çàäàí 
# ïàðàìåòð &filter_func, òî ýòà ôóíêöèÿ âûçûâàåòñÿ äëÿ êàæäîé ïîäñòðîêè 
# âíå <? è ?>. Îíà äîëæíà âîçâðàùàòü îáðàáîòàííóþ ñòðîêó. Íî åñëè â 
# íåé ïîÿâÿòñÿ <? è ?>, îíè óæå íå áóäóò îáðàáîòàíû!
sub Compile($;$)
{ my ($Cont,$filter)=@_;
  $Cont =~ s{^\t*}{}mgo;
  $Cont="?>$Cont<?";
  $Cont=~s{<\?=}{<?print }sgo;
  if(!$filter) {

# èñïîëüçîâàòü â "ïî÷òîâûõ" öåëÿõ. Åñëè çàäàí ïàðàìåòð $CacheId, òî 
# øàáëîí êýøèðóåòñÿ, è äëÿ ñëåäóþùåãî âûçîâà ExpandTemplate() 
# ñ òàêèì æå $CacheId êîìïèëèðîâàíèå øàáëîíà óæå íå ïðîèçîéäåò.
# Ïàðàìåòð $Filename âëèÿåò òîëüêî íå ñîîáùåíèÿ îá îøèáêàõ, êîòîðûå 
# ìîãóò âîçíèêíóòü â øàáëîíå $Templ.
sub Expand($;$;$;$)
{ my ($Templ,$CacheId,$Filename,$pkg)=@_;
  my $Compiled;
  if(defined($CacheId) && exists($ExpandCache{$CacheId})) {
    $Compiled=$ExpandCache{$CacheId}; 
  } else {

  return;
}

# string ExpandFile($fname)
# Òî æå, ÷òî è Expand(), òîëüêî ñ÷èòûâàåò ôàéë ñ äèñêà.
sub ExpandFile($)
{ my ($fname)=@_;
  local *F;
  if(!open(F,$fname)) {
    require Carp;
    Carp::croak("Could not open the file $fname");

}

# string _Slash(string $st)
# Ïðîñòàâëÿåò ñëýøè ïåðåä ñïåöèàëüíûìè ñèìâîëàìè, à òàêæå îáðàáàòûâàåò
# âõîæäåíèÿ ñèìâîëîâ-ðàçäåëèòåëåé.
sub _Slash($)
{ my ($st)=@_;
  $st=~s/$c0/$c0."$c0".qq$c0/g;
  $st=~s/(\r?\n\s*#line\s*\d[^\n]*\r?\n)/$c0;$1print qq$c0/gs;
  $st=~s/\\(?!\$)/\\\\/g;
  $st=~s/\@/\\\@/g;

view all matches for this distribution

CGI-ExtDirect

1 match

examples/p5httpd view on Meta::CPAN

main_loop();
exit;

################################## Subroutines ###################

sub logerr($$);
sub logmsg($);
sub log_and_die($);
sub cat($$;$);    # forward declarations

sub initialise {
  $HOSTNAME = $ENV{HOSTNAME} || "localhost";
  $I_am_child = 0
    ; # Will be 1 in child after a fork(). Children wil just exit after finishing work.

examples/p5httpd view on Meta::CPAN


# cat "relative/path", "text/html", $method; writes the appropriate
# response headers to STDOUT. If $method == GET (which is the default)
# then the file is dumped on STDOUT as well.

sub cat($$;$) {
  my ( $file, $mimetype, $method ) = @_;
  $method = "GET" unless $method;
  my $fullpath = "$server_root$file";

  my ( undef, undef, undef, undef, undef, undef, undef, $length, undef, $mtime )

view all matches for this distribution

CGI-FormBuilderX-More

1 match

lib/CGI/FormBuilderX/More.pm view on Meta::CPAN

            return ! defined $_[0] || $_[0] eq '';
        } },
    ],
};

sub _attribute($) {
    return "_CGI_FBX_M_$_[0]";
}

=head1 METHODS

view all matches for this distribution

CGI-Info

1 match

lib/CGI/Info.pm view on Meta::CPAN

# use Sub::Private;
use Sys::Path;

use namespace::clean;

sub _sanitise_input($);

=head1 NAME

CGI::Info - Information about the CGI environment

lib/CGI/Info.pm view on Meta::CPAN

	if($params) {
		return $params->{$field};
	}
}

sub _sanitise_input($) {
	my $arg = shift;

	# Remove hacking attempts and spaces
	$arg =~ s/[\r\n]//g;
	$arg =~ s/\s+$//;

view all matches for this distribution

CGI-Kwiki

1 match

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

}


#line 423

sub cmp_ok($$$;$) {
    $Test->cmp_ok(@_);
}


#line 457

view all matches for this distribution

CGI-Multiscript

1 match


}

# Create a temporary file
# With a random name
sub get_tmpfilename() {
	my $tmpname;
	my $random;

	$tmpname = ".ms.";
	srand(time());


	return ($tmpname);

}

sub set_writeflag()
{
	my $flag = $_[0];
	if ($writeflag != 0) {
	print "Code Error -- Not allowed nested code within code!!\n";
		unlink($tmpfilename);

	}
	$writeflag = $flag; 

}

sub clear_writeflag()
{
  	my $flag = $_[0];
  	$writeflag = 0;
}

sub execTmpfile()
{
	my ($lang, $args) = @_;
	my $returncode;

	# print "executing 1 $lang $tmpfilename\n";

	}
	
}


sub truncateTmpfile()
{
	seek($TMPFILE, 0, 0);
	truncate($TMPFILE, 0);
}

view all matches for this distribution

CGI-Mungo

1 match

lib/CGI/Mungo/Response/TemplateToolkit.pm view on Meta::CPAN

as [% message %].

=cut

#########################################################
sub setError(){
	my($self, $message) = @_;
	$self->setTemplateVar("message", $message);	#so we can access the error message via smarty
	return $self->SUPER::setError($message);	#save the message for later in the instance
}
#########################################################

view all matches for this distribution

CGI-OptimalQuery

1 match

lib/CGI/OptimalQuery/InteractiveFilter.pm view on Meta::CPAN

    $ftext =~ s/\n//g;
    return $ftext;
}

# ------------------------- delselForm -------------------------
sub delselForm( $ ) {
    my( $q ) = @_;

    my $oei = scalar $q->param('FINDX');
    my $ni=1;
    for( my $oi = 1; $oi <= $oei; $oi++ ) {

lib/CGI/OptimalQuery/InteractiveFilter.pm view on Meta::CPAN

# ------------------------- cmpopLOV -------------------------
sub cmpopLOV { ['=','!=','<','<=','>','>=','like','not like','contains','not contains'] }


# ------------------------- html_parent_update -------------------------
sub html_parent_update( $ ) {

    my ($o) = @_;

    my $q = $o->{q};

lib/CGI/OptimalQuery/InteractiveFilter.pm view on Meta::CPAN


    return $doc;
}

# ------------------------- getFunctionNames -------------------------
sub getFunctionNames( $ ) {
    my( $o ) = @_;
    my %functs = (); # ( t1=>'Test One', t2=>"Test Two" );
    foreach my $k ( keys %{$o->{schema}->{'named_filters'}} ) {
	my $fref = $o->{schema}->{'named_filters'}{$k};
        if (ref $fref eq 'ARRAY') { $functs{"$k".'()'} = $fref->[2]; }

lib/CGI/OptimalQuery/InteractiveFilter.pm view on Meta::CPAN

    }
    return %functs;
}

# ------------------------- getColumnNames -------------------------
sub getColumnNames( $ ) {
    my( $o ) = @_;
    my %cols = (); # ( t1=>'Test One', t2=>"Test Two" );
    foreach my $k ( keys %{$o->{schema}->{'select'}} ) {
        next if $$o{schema}{select}{$k}[3]{is_hidden};
	my $cref = $o->{schema}->{'select'}{$k};

lib/CGI/OptimalQuery/InteractiveFilter.pm view on Meta::CPAN

    }
    return %cols;
}

# ------------------------- html_filter_form -------------------------
sub html_filter_form( $ ) {
    my( $o ) = @_;
    
    my %columnLBL = $o->getColumnNames();
    my @columnLOV = sort { $columnLBL{$a} cmp $columnLBL{$b} } keys %columnLBL;
    # TODO:  create named_functions from pre-exising filters and use them

view all matches for this distribution

CGI-Shorten

1 match

Shorten.pm view on Meta::CPAN


    undef $self->{_id};
}    

# ----------------------------------------------------------------------
sub shorten($$) {
    my ($self, $url) = @_;
    my $shurl = $self->{_script_url}.'?'.$self->{_id}->bstr();
    $self->{_lndb}->{$self->{_id}} = $url;
    $self->{_id}++;
    $shurl;
}

# ----------------------------------------------------------------------
sub lengthen($$) {
    my ($self, $url) = @_;
    if($url =~ s/^\Q$self->{_script_url}?\E//o ){
	return $self->{_lndb}->{$'};
    }
}

# ----------------------------------------------------------------------
sub redirect($$) {
    die "Where is your redirection url\n" unless $_[1];
    my $lnurl = $_[0]->lengthen($_[1]);
    return $lnurl ? $cgi->redirect($lnurl) : $cgi->header(-status=> '404'),
}

view all matches for this distribution

CGI-Simple

1 match

lib/CGI/Simple.pm view on Meta::CPAN

  else {
    $self->_parse_params( $init );    # initialize from a query string
  }
}

sub _internal_read($*\$;$) {
  my ( $self, $glob, $buffer, $len ) = @_;
  $len = 4096 if !defined $len;
  if ( $self->{'.mod_perl'} ) {
    my $r = $self->_mod_perl_request();
    $r->read( $$buffer, $len );

view all matches for this distribution

CGI-WebOut

1 match

  tie(*STDOUT, __PACKAGE__."::Tie", \*STDOUT, tied(*STDOUT));
}


# Ïðîâåðÿåò, èñïîëüçóåòñÿ ëè áèáëèîòåêà Web-ñêðèïòîì èëè îáû÷íûì
sub IsWebMode() { 
  return $ENV{SCRIPT_NAME}? 1 : 0 
}


# Ïîñëàíû ëè çàãîëîâêè?

# } catch {
#     die "An error occurred while grabbing the output: $@";
# };
# èëè òî æå, íî áåç catch: 
# $grabbed = grab { print 'Hello!' };
sub grab(&@)
{ my ($func, $catch)=@_;
  my $Buf = CGI::WebOut->new; 
  $@ = undef; eval { &$func() };
  if ($@ && $catch) { chomp($@); local $_ = $@; &$catch; }
  return $Buf->buf;
}


# static Header($header)
# Óñòàíàâëèâàåò çàãîëîâîê îòâåòà.
sub Header($)
{ my ($head)=@_;
  if ($HeadersSent) {
    eval { require Carp } 
      and Carp::carp("Oops... Header('$head') called after content had been sent to browser!\n"); 
    return undef;

  return 1;
}


# Ñáðàñûâàåò ñîäåðæèìîå ãëàâíîãî áóôåðà â áðàóçåð.
sub Flush() { 
  # Îòêëþ÷àåì âíóòðåííþþ áóôåðèçàöèþ Perl-à
  local $| = 1; 
  # Åñëè çàãîëîâêè åùå íå îòîñëàíû, îòîñëàòü èõ
  if (!$HeadersSent && IsWebMode()) {
    my $ContType="text/html";

  # Âîçâðàùàåì çíà÷åíèå, êîòîðîå âåðíóë try-áëîê
  return wantarray? @Result: $Result[0];
}

# Âîçâðàùàåò ôóíêöèþ-çàìûêàíèå, êîòîðàÿ âûçûâàåò òåëî catch-áëîêà.
sub catch(&;@) 
{ my ($body, @Hand)=@_;
  return (sub { if($@) { chomp($@); local $_=$@; &$body($_) } }, @Hand);
}

# Âîçâðàùàåò ôóíêöèþ-çàìûêàíèå, êîòîðàÿ âûçûâàåò òåëî warnings-áëîêà.
sub warnings(&;@) 
{ my ($body,@Hand)=@_;
  return (sub { &$body(@Warns) }, @Hand);
}

# Âûáðàñûâàåò èñêëþ÷åíèå.
sub throw($) { 
  die(ref($_[0])? $_[0] : "$_[0]\n") 
}


# bool SetAutoflush([bool $mode])
# Óñòàíàâëèâàåò ðåæèì ñáðîñà áóôåðà echo: åñëè $mode=1, òî ðàçðåøàåò åãî àâòîñáðîñ ïîñëå
# êàæäîãî âûâîäà print èëè echo, èíà÷å - çàïðåùàåò (ñáðîñ äîëæåí ïðîèçâîäèòüñÿ ïî Flush()).
# Âîçâðàùàåò ïðåäûäóùèé óñòàíîâëåííûé ðåæèì àâòîñáðîñà.
sub SetAutoflush(;$)
{ my ($mode)=@_;
  my $old = $UseAutoflush;
  if (defined $mode) { $UseAutoflush = $mode; }
  return $old;
}

# bool NoAutoflush()
# Çàïðåùàåò ñáðàñûâàòü áóôåð ïîñëå êàæäîãî echo.
# Âîçâðàùàåò ïðåäûäóùèé ñòàòóñ àâòîñáðîñà.
sub NoAutoflush() {
  return SetAutoflush(0);
}


# bool UseAutoflush()
# Ðàçðàøàåò ñáðàñûâàòü áóôåð ïîñëå êàæäîãî echo.
# Âîçâðàùàåò ïðåäûäóùèé ñòàòóñ àâòîñáðîñà.
sub UseAutoflush() {
  return SetAutoflush(1);
}


# Ïåðåíàïðàâëÿåò íà äðóãîé URL (ìîæåò áûòü âíóòðåííèì ðåäèðåêòîì)
sub Redirect($)
{ my ($url) = @_;
  $Redirected = Header("Location: $url");
  exit;
}


# Ïåðåíàïðàâëÿåò ÁÐÀÓÇÅÐ íà äðóãîé URL
sub ExternRedirect($)
{ my ($url) = @_;
  if ($url !~ /^\w+:/) {
    # Îòíîñèòåëüíûé àäðåñ.
    if ($url !~ m{^/}) {
      my $sn = $ENV{SCRIPT_NAME};

  exit;
}


# Çàïðåùàåò êýøèðîâàíèå äîêóìåíòà áðàóçåðîì
sub NoCache()
{ return 1 if $NoCached++;
  Header("Expires: Mon, 26 Jul 1997 05:00:00 GMT") or return undef;
  Header("Last-Modified: ".gmtime(time)." GMT") or return undef;
  Header("Cache-Control: no-cache, must-revalidate") or return undef;
  Header("Pragma: no-cache") or return undef;

# 0 - îøèáêè íå âûâîäÿòñÿ
# 1 - îøèáêè âûâîäÿòñÿ â áðàóçåð
# 2 - îøèáêè âûâîäÿòñÿ â áðàóçåð â âèäå êîììåíòàðèåâ
# Åñëè ïàðàìåòð íå çàäàí, ðåæèì íå ìåíÿåòñÿ.
# Âîçâðàùàåò ïðåäûäóùèé ñòàòóñ âûâîäà.
sub ErrorReporting(;$)
{ my ($lev)=@_;
  my $old = $ErrorReporting;
  $ErrorReporting = $lev if defined $lev;
  return $old;
}


# Äîáàâëÿåò ñîîáùåíèå îá îøèáêå ê ìàññèâó îøèáîê.
sub Warning($)
{ my ($msg)=@_;
  push(@Errors, $msg);
}


# Ïå÷àòàåò âñå íàêîïèâøèåñÿ ñîîáùåíèÿ îá îøèáêàõ.
# Ýòà ôóíêöèÿ âûçûâàåòñÿ â ìîìåíò, êîãäà STDOUT íàõîäèòñÿ â "ïîäâåøåííîì" ñîñòîÿíèè, 
# ïîýòîìó èñïîëüçîâàíèå print ÇÀÏÐÅÙÅÍÎ!!!
sub __PrintAllErrors()
{ local $^W = undef;
  # http://forum.dklab.ru/perl/symbiosis/Fastcgi+WeboutUtechkaPamyati.html
  if(!@Errors || !$ErrorReporting){
    @Errors=(); 
          return ;

view all matches for this distribution

CGI-Wiki-Simple

1 match

t/01-api.t view on Meta::CPAN


use vars qw( @runmodes );
@runmodes = qw(display preview commit);
                           
# Declare what we expect :
sub is_path_info($$$$) {
  my ($path_info,$expected_runmode,$expected_node_title,$comment) = @_;

  my %node_info = (content => 'Test content', checksum => 1);
  my $cgi = Test::MockObject->new()
                            ->set_always( param => undef )

view all matches for this distribution

CGI-XMLForm

1 match

XMLForm.pm view on Meta::CPAN

	delete $expat->{_currenttree};
	delete $expat->{_requests};
	return $expat->{_parseresults};
}

sub formatElement($$) {
	# Properly formats elements whether opening or closing.

	my $cgi = shift;
	my $open = shift;
	my $element = shift;

view all matches for this distribution

CGISession

1 match


=back

=cut

sub new($$@)
  {
    my ( $type ) = shift;
    my ( $cgi ) = shift;

    my $self = {};

  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;


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


=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'};


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
#


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

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.
#

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.


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


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->{%}; }

                                              -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


  print "Session has passkey: ".( $session->has_passkey ? "YES" : "NO" )."\n";

=cut

sub has_passkey($)
  {
    my $self = shift;
    return $self->cgi->param($self->passkey_name);
  }


 $passkey_field = $session->passkey_field;

=cut

sub passkey_field($)
  {
    my $self = shift;
    my $passkey = $self->passkey;
    my $passkey_name = $self->passkey_name;

    Session was confirmed...
  }

=cut

sub confirmed($;$)
  {
    my ($self) = shift;

    my $passkey = @_ ? shift : $self->cgi->param( $self->passkey_name );

    Authentication Failed
  }

=cut

sub confirm($;$) { my $self = shift; $self->confirmed(@_); }


# Authenticate User (at beginning)
#
# $session->authenticated( $username, $password );

      Authentication Failed
    }

=cut

sub authenticated($$$) {
    my ($self,$username, $password) = @_;
    $username = defined $username ? $username : "";
    $password = defined $password ? $password : "";

    # the skeleton key!

      Authentication Failed
    }

=cut

sub authenticate($$$)
  {
    my ( $self, $username, $password ) = @_;
    if ( $self->authenticated( $username, $password ) )
      {
	$self->set_passkey( $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.


=back

=cut

sub header($@)
  {
    my ($self) = shift;
    my $header;

    # If this is being used with a custom CGI, then we just call the

#     Functions      #
#                    #
######################


sub ConnectToDatabase($)
  {
    my $self = shift;
    if ( !defined $self->dbi )
      {
        my $dbi = DBI->connect( $self->dbi_dn, $self->dbi_username, $self->dbi_password );

      }
    
    return 0;
}

sub DisconnectDatabase($)
  {
    my ($self) = @_;
    if ( $self->dbi )
      {
        $self->dbi_statement->finish if $self->dbi_statement;

    $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.
    #

    # 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 ".

	return 0;
      }

}

sub FetchSQLData($)
  {
    my $self = shift;
    if (!defined $self->dbi)
      {
        croak "Programmer Error: Attempted to get data from a closed DBI connection.\n ".


    return $self->dbi_statement->fetchrow_array;
}


sub FetchOneColumn($)
  {
    my ($self) = @_;
    my @row = $self->FetchSQLData();
    return $row[0];
  }

      ... perform action for defined user ...
    }

=cut

sub user_exists($$)
  {
    my ($self,$username) = @_;
    
    my $cookie_table = $self->cookie_table;
    my $user_column = $self->user_column;

      $self->register_username( $username );
    }

=cut

sub register_username($$)
  {
    my ($self,$username) = @_;
    return unless $self->register;
    return if $self->user_exists($username);


  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,


   $self->set_login_cookie();

=cut

sub set_login_cookie($;$)
  {
    my ($self) = shift;
    
    my $cookie_table = $self->cookie_table;
    my $user_column = $self->user_column;


  $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 );


   my $username = $self->username();

=cut

sub username($)
#
# Gets the user ID for the current session.
#
# my $username = $session->username;
#


   $self->set_passkey();

=cut

sub set_passkey($;$)
  {
    my ($self) = shift;

    my $pass = int(rand 9999999)+1;


    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,


    my $cookie = $self->set_logout_cookie();

=cut

sub set_logout_cookie($)
  {
    my ($self) = @_;

    my $logout_cookie = $self->logout_cookie;
    $self->cookie( $logout_cookie );


    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 = {};

    $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;


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;

      {
	return _param( $self, "-session" );
      }
  }

sub _param($@)
  {
    my $self = shift;
    if ( scalar @_ == 1 )
      {
	my $field = shift;

	    $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 )
      {

      }
    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.

      }
    $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(</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} )

view all matches for this distribution

CGP-CLI

1 match

lib/CGP/CLI.pm view on Meta::CPAN

  }
  return $result;
}


sub readKey() {
  my $this = shift;
  return $this->readWord();
}


sub readValue() {
  my $this = shift;
  $this->skipSpaces();
  my $ch=substr($this->{'data'},$this->{'span'},1);
  if($ch eq '{') {
    ++$this->{'span'};

lib/CGP/CLI.pm view on Meta::CPAN

  } else {
    return $this->readWord();
  }
}

sub readArray() {
  my $this = shift;
  my $result=[];
  while($this->{'span'}<$this->{'len'}) {
    $this->skipSpaces();
    if(substr($this->{'data'},$this->{'span'},1) eq ')') {

view all matches for this distribution

CIAO-Lib-Param

1 match

ppport.h view on Meta::CPAN

    my $version = int_parse_version(shift);
    $version =~ s/^5\B/5./;
    return $version;
}

sub dictionary_order($$)    # Sort caselessly, ignoring punct
{
    my ($lc_a, $lc_b);
    my ($squeezed_a, $squeezed_b);
    my ($valid_a, $valid_b);    # Meaning valid for all releases

view all matches for this distribution

CLI-Coin-Toss

2 results

scripts/boxmuller view on Meta::CPAN

  sub lognormal ( $$ ) { 
  	return exp boxmuller $_[0], $_[1] ;
  }
}

sub SecondInfo( ) {   #  å‡¦ç†ã—ãŸã“ã¨ã«ã¤ã„ã¦ã®äºŒæ¬¡æƒ…å ±ã‚’å‡ºåŠ›
    return if $o{1} ;
    use FindBin qw [ $Script ] ; 
    my $cmd = "$Script -m $mu -d $sd" ; 
    $cmd .= ' -l' if $o{l} ;
    print STDERR

view all matches for this distribution

CLI-Table-Key-Finder

1 match

scripts/alluniq view on Meta::CPAN

	      "  ($Script)\n"  ;
	    return 1 ; 
	}
}

sub tableOutput( ) { 
    ## 2. åº¦æ•°nã®ç•°ãªã‚‹æ–‡å—åˆ—ãŒã€å…·ä½“çš„ã«ã©ã‚“ãªå€¤ã§ã‚ã£ãŸã‹ã€‚
    while ( my( $str, $cnt) = each %str2cnt ) {
       push @{ $cnt2strs {$cnt} }, $str ; 
    }
    my $msep = $o{2} ? "\n" : "\t"  ;

view all matches for this distribution

CLI-TextLines-Utils

1 match

scripts/alluniq view on Meta::CPAN

	      CYAN "  ($Script)\n"  ;
	    return 1 ; 
	}
}

sub tableOutput( ) { 
    ## 2. åº¦æ•°nã®ç•°ãªã‚‹æ–‡å—åˆ—ãŒã€å…·ä½“çš„ã«ã©ã‚“ãªå€¤ã§ã‚ã£ãŸã‹ã€‚
    while ( my( $str, $cnt) = each %str2cnt ) {
       push @{ $cnt2strs {$cnt} }, $str ; 
    }
    my $msep = $o{2} ? "\n" : "\t"  ;

view all matches for this distribution

CLI

1 match

CLI.pm view on Meta::CPAN

use constant BOOLEAN => 7;

sub parse_string ($$);
sub typeStr ($);
sub hashmatch ($$\@);
sub string_value($$);

use CLI::Var;
use CLI::Hash;
use CLI::Command;
use CLI::Array;

view all matches for this distribution

CMS-MediaWiki

1 match

lib/CMS/MediaWiki.pm view on Meta::CPAN

my $ua;

$| = 1;

#-----  FORWARD DECLARATIONS & PROTOTYPING
sub Error($);
sub Debug($);

sub new {
	my $type = shift;
	my %params = @_;
	my $self = {};

view all matches for this distribution

CONFIG

2 results

		}
	}
	return @list;	
}

sub config_type($) {
	my ($file) = @_;

	return $CONFIG::Plain::already_open_configs{$file}->{'_CODE_TYPE'};
}

sub file_last_changed($) {
	my ($self) = @_; 
	return $self->{COMMON}->{FILETIME};
}

sub file_last_read($) {
	my ($self) = @_;
	return $self->{COMMON}->{LASTREAD};
}

sub file_size($) {
	my ($self) = @_;
	return $self->{COMMON}->{FILEBYTES};
}

sub file_lines($) {
	my ($self) = @_;
	return $self->{COMMON}->{FILELINES};
}

sub cache_size($) {
	my ($self) = @_;
	return $self->{COMMON}->{CACHEBYTES};
}

sub cache_lines($) {
	my ($self) = @_;
	return $self->{COMMON}->{CACHELINES};
}
sub file_read($) {
	my ($self) = @_;
	return $self->{COMMON}->{USED};
}

sub file_config($) {
	my ($self) = @_;
	my %hash;
	
	%hash = %{$self->{COMMON}->{CONFIG}};

	$self->{COMMON}->{_CODE_TYPE} = 'Plain';
	
	$self->parse_file;
}

sub check_for_include($$$) {
	my ($self, $line, $linenr) = @_;
	my ($before, $filename, $after);
	my ($file, $pwd, $error, $src_line, $src_file);
	my $cursor;

		}
	}
	return \%COMMENT_FUNCTIONS;
}

sub getline_unparsed($$) {
	my ($self, $linenr) = @_;

	return $self->{COMMON}->{LINESFILE_unparsed}->[$linenr];
}