^sub \w+\( results from the CPAN

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(@_);
}

    return $obj;
}

#line 719

sub subtest($&) {
    my ($name, $subtests) = @_;

    my $tb = Test::More->builder;
    return $tb->subtest(@_);
}

view all matches for this distribution

Algorithm-LBFGS

3 results

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

}


#line 425

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

    $tb->cmp_ok(@_);
}

view all matches for this distribution

Algorithm-LDA

1 match

bin/lda.pl view on Meta::CPAN

}

##############################################################################
#  function to output help messages for this program
##############################################################################
sub showHelp() {
        
    print "This is a utility that takes as directory of documents, performs LDA\n";
    print "and stores the results in the Results directory.\n\n";

    print "Usage: lda.pl [OPTIONS] DIR\n\n";

view all matches for this distribution

Algorithm-LatticePoints

1 match

lib/Algorithm/LatticePoints.pm view on Meta::CPAN


require Exporter;

our $VERSION = sprintf "%d.%02d", q$Revision: 0.1 $ =~ /(\d+)/g;

sub new($&){
    my $class = shift;
    my $coderef = shift;
    bless $coderef, $class;
}

view all matches for this distribution

Algorithm-Loops

1 match

    }
    die "$sub: ", @_, ".\n";
}


sub Filter(&@)
{
    my( $code, @vals )= @_;
    isa($code,"CODE")  or  _Croak(
        "No code reference given" );
    # local( $_ ); # Done by the loop.

    }
    wantarray ? @vals : join "", @vals;
}


sub MapCarE(&@)
{
    my $sub= shift(@_);
    isa($sub,"CODE")  or  _Croak(
        "No code reference given" );
    my $size= -1;

    }
    return wantarray ? @ret : \@ret;
}


sub MapCarMin(&@)
{
    my $sub= shift(@_);
    isa($sub,"CODE")  or  _Croak(
        "No code reference given" );
    my $min= -1;

    }
    return wantarray ? @ret : \@ret;
}


sub MapCarU(&@)
{
    my $sub= shift(@_);
    isa($sub,"CODE")  or  _Croak(
        "No code reference given" );
    my $max= 0;

    }
    return wantarray ? @ret : \@ret;
}


sub MapCar(&@)
{
    my $sub= shift(@_);
    isa($sub,"CODE")  or  _Croak(
        "No code reference given" );
    my $max= 0;

    }
    return wantarray ? @ret : \@ret;
}


sub NextPermute(\@)
{
    my( $vals )= @_;
    my $last= $#{$vals};
    return !1   if  $last < 1;
    # Find last item not in reverse-sorted order:

    @{$vals}[$i,$j]= @{$vals}[$j,$i];
    return 1;
}


sub NextPermuteNum(\@)
{
    my( $vals )= @_;
    my $last= $#{$vals};
    return !1   if  $last < 1;
    # Find last item not in reverse-sorted order:

view all matches for this distribution

Algorithm-Retry

1 match

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


DONE_TESTING:
done_testing;

# XXX temporary function
sub rand_between_ok(&$$) {
    my ($block, $min, $max, $name) = @_;
    my @res;
    my %res;
    for (1..10) {
        my $res = $block->();

view all matches for this distribution

Algorithm-SISort

1 match

SISort.pm view on Meta::CPAN


our @EXPORT = qw( );

our $VERSION = '0.14';

sub Sort(&@) {
	my $callback=shift;
	_sort($callback, \@_);
	return @_;
}

sub Sort_inplace(&\@) {
	my $callback=shift;
	return _sort($callback, $_[0]);
}

1;

view all matches for this distribution

Algorithm-TSort

2 results

lib/Algorithm/TSort.pm view on Meta::CPAN

	return bless $_[1], $_[0];
    }
    sub DESTROY { $_[0]->() };
}

sub Graph($$) {
    my $what = shift;
    my $data = shift;
    die "Graph: undefined input" unless defined $what;
    if ( $what eq 'IO' || $what eq 'SCALAR' ) {
        my %c;

lib/Algorithm/TSort.pm view on Meta::CPAN

    }
}


# Preloaded methods go here.
sub tsort($;@) {
    my $object = shift;
    my @nodes  = @_;
    my @sorted;
    my %seen;
    my $req_sub;

view all matches for this distribution

Algorithm-TrunkClassifier

5 results

lib/Algorithm/TrunkClassifier/Classification.pm view on Meta::CPAN

#Description: Function responsible for building decision trunks and classifying test samples using LOOCV
#Parameters: (1) Package, (2) input dataset, (3) test dataset, (4) classification procedure, (5) split percent,
#            (6) testset data file name, (7) classification variable name, (8) output folder name,
#            (9) number of levels, (10) verbose flag, (11) input data file name (12) useall flag
#Return value: None
sub trainAndClassify($ $ $ $ $ $ $ $ $ $ $ $ $){
	shift(@_);
	my ($dataWrapper, $testset, $CLASSIFY, $SPLITPERCENT, $TESTFILE, $CLASSNAME, $OUTPUT, $LEVELS, $VERBOSE, $DATAFILE, $USEALL) = @_;
	
	#Create output files
	if(!-e $OUTPUT && $OUTPUT ne "."){

lib/Algorithm/TrunkClassifier/Classification.pm view on Meta::CPAN


#Description: Wrapper for the trunk build loop
#Parameters: (1) Training dataset, (2) level limit, (3) sample index, (4) feature occurrence hash ref,
#            (5) selected features hash ref, (6) level break flag ref, (7) verbose flag
#Return value: Decision trunk object
sub buildTrunk($ $ $ $ $ $ $){
	my ($buildSet, $levelLimit, $sampleIndex, $featOccurRef, $selFeatRef, $levelBreakRef, $VERBOSE) = @_;
	
	#Trunk build loop
	my $decisionTrunk = Algorithm::TrunkClassifier::DecisionTrunk->new();
	my $noSampleBreak = 0;

lib/Algorithm/TrunkClassifier/Classification.pm view on Meta::CPAN

}

#Description: Determine the decision trunk level with highest feature selection stability
#Parameters: (1) Hash reference containing selected features, (2) number of samples in the dataset
#Return value: Number of decision trunk levels to use for classification
sub stabilityCheck($ $){
	my ($hashRef, $numSamples) = @_;
	my %featOccurrence = %{$hashRef};
	my $numThresh = 6;
	my $chosenLevel = 0;
	foreach my $levelIndex (1 .. 5){

view all matches for this distribution

Alien-CodePress

1 match

cp/codepress/index.html view on Meta::CPAN


# Some simple printing
print $var1; 

# Subroutine
sub test() {
	print "ok";
}
</textarea>

<textarea id="cp-sql" class="hidden-code">

view all matches for this distribution

Alien-LibUSBx

1 match

Build.PL view on Meta::CPAN

use Env qw/ALIEN_LIBUSBX_CFLAGS ALIEN_LIBUSBX_LIBS/;

my $libusbx_version = '1.0.17';

# Override the CFLAGS/LIBS settings
sub alien_override($$$$) {
    my ($builder, $version, $cflags, $libs) = @_;
    my $dirname = '_dummy';
    my $filename = "dummy-$version.tar";

    unless (-d $dirname) {

view all matches for this distribution

Alt-Acme-Math-XS-CPP

1 match

                "vars"     => "",
            }, $class;
    }
}

sub reset($)
{
    @{$_[0]->{"prods"}} = ();
    @{$_[0]->{"calls"}} = ();
    $_[0]->{"changed"}  = 0;
    $_[0]->{"impcount"}  = 0;

    $_[0]->{"vars"}  = "";
}

sub DESTROY {}

sub hasleftmost($$)
{
    my ($self, $ref) = @_;

    my $prod;
    foreach $prod ( @{$self->{"prods"}} )

    }

    return 0;
}

sub leftmostsubrules($)
{
    my $self = shift;
    my @subrules = ();

    my $prod;

    }

    return @subrules;
}

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

    my $prod;

    }

    return join ', or ', @expected;
}

sub _contains($@)
{
    my $target = shift;
    my $item;
    foreach $item ( @_ ) { return 1 if $target eq $item; }
    return 0;
}

sub addcall($$)
{
    my ( $self, $subrule ) = @_;
    unless ( _contains($subrule, @{$self->{"calls"}}) )
    {
        push @{$self->{"calls"}}, $subrule;
    }
}

sub addprod($$)
{
    my ( $self, $prod ) = @_;
    push @{$self->{"prods"}}, $prod;
    $self->{"changed"} = 1;
    $self->{"impcount"} = 0;

    $self->{"autoscore"} = $code;
    $self->{"changed"} = 1;
    return 1;
}

sub nextoperator($)
{
    my $self = shift;
    my $prodcount = scalar @{$self->{"prods"}};
    my $opcount = ++$self->{"opcount"};
    return "_operator_${opcount}_of_production_${prodcount}_of_rule_$self->{name}";
}

sub nextimplicit($)
{
    my $self = shift;
    my $prodcount = scalar @{$self->{"prods"}};
    my $impcount = ++$self->{"impcount"};
    return "_alternation_${impcount}_of_production_${prodcount}_of_rule_$self->{name}";


    return $code;
}

my @left;
sub isleftrec($$)
{
    my ($self, $rules) = @_;
    my $root = $self->{"name"};
    @left = $self->leftmostsubrules();
    my $next;

    my ($self, $ref) = @_;
    return ${$self->{"items"}}[0] eq $ref  if scalar @{$self->{"items"}};
    return 0;
}

sub isempty($)
{
    my $self = shift;
    return 0 == @{$self->{"items"}};
}

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

    if ( $#{$self->{"items"}} >= 0 )
    {

    }

    return ();
}

sub checkleftmost($)
{
    my @items = @{$_[0]->{"items"}};
    if (@items==1 && ref($items[0]) =~ /\AParse::RecDescent::Error/
        && $items[0]->{commitonly} )
    {

        return 0;
    }
    return 1;
}

sub changesskip($)
{
    my $item;
    foreach $item (@{$_[0]->{"items"}})
    {
        if (ref($item) =~ /Parse::RecDescent::(Action|Directive)/)

        $itempos[$#itempos]{'line'}{'to'}   = $prevline;
        $itempos[$#itempos]{'column'}{'to'} = $prevcolumn;
    }
}

sub code($$$$)
{
    my ($self,$namespace,$rule,$parser) = @_;
    my $code =
'
    while (!$_matched'

}

sub issubrule { undef }
sub isterminal { 0 }

sub code($$$$)
{
    my ($self, $namespace, $rule) = @_;

'
        Parse::RecDescent::_trace(q{Trying action},

        "line"      => $_[3],
        "name"      => $_[4],
    }, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule) = @_;

'
        ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'

}

# MARK, YOU MAY WANT TO OPTIMIZE THIS.


sub code($$$$)
{
    my ($self, $namespace, $rule) = @_;

'
        Parse::RecDescent::_trace(q{>>Rejecting production<< (found '

        "commitonly" => $_[3],
        "line"       => $_[4],
    }, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule) = @_;

    my $action = '';

        "description" => $desc,
    }, $class;
}


sub code($$$$$)
{
    my ($self, $namespace, $rule, $check) = @_;
    my $ldel = $self->{"ldelim"};
    my $rdel = $self->{"rdelim"};
    my $sdel = $ldel;

        "description" => "'$desc'",
    }, $class;
}


sub code($$$$)
{
    my ($self, $namespace, $rule, $check) = @_;

my $code = '
        Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe

        "line"      => $_[3],
        "description" => "'$desc'",
    }, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule, $check) = @_;

my $code = '
        Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe

    my $desc = $_[0]->{"implicit"} || $_[0]->{"subrule"};
    $desc = "<matchrule:$desc>" if $_[0]->{"matchrule"};
    return $desc;
}

sub callsyntax($$)
{
    if ($_[0]->{"matchrule"})
    {
        return "&{'$_[1]'.qq{$_[0]->{subrule}}}";
    }

        "argcode"   => $_[6] || undef,
    }, $class;
}


sub code($$$$)
{
    my ($self, $namespace, $rule, $check) = @_;

'
        Parse::RecDescent::_trace(q{Trying subrule: [' . $self->{"subrule"} . ']},

    my $desc = $_[0]->{"expected"} || $_[0]->{"subrule"};
    $desc = "<matchrule:$desc>" if $_[0]->{"matchrule"};
    return $desc;
}

sub callsyntax($$)
{
    if ($_[0]->{matchrule})
        { return "sub { goto &{''.qq{$_[1]$_[0]->{subrule}}} }"; }
    else
        { return "\\&$_[1]$_[0]->{subrule}"; }

        "argcode"   => $argcode || undef,
        "matchrule" => $matchrule,
    }, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule, $check) = @_;

    my ($subrule, $repspec, $min, $max, $lookahead) =
        @{$self}{ qw{subrule repspec min max lookahead} };

    my ($class, $pos) = @_;

    bless {}, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule) = @_;

    '
        $return = $item[-1];

        "rightarg"  => $rightarg,
        "expected"  => "<${type}op: ".$leftarg->describe." ".$op->describe." ".$rightarg->describe.">",
    }, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule, $check) = @_;

    my @codeargs = @_[1..$#_];


# BUILDING A PARSER

my $nextnamespace = "namespace000001";

sub _nextnamespace()
{
    return "Parse::RecDescent::" . $nextnamespace++;
}

# ARGS ARE: $class, $grammar, $compiling, $namespace


    bless $self, $class;
    return $self->Replace($_[1])
}

sub Compile($$$$) {
    die "Compilation of Parse::RecDescent grammars not yet implemented\n";
}

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

    if ($ERRORS) { $ERRORS=0; return }
    return $self;
}


sub _addstartcode($$)
{
    my ($self, $code) = @_;
    $code =~ s/\A\s*\{(.*)\}\Z/$1/s;

    $self->{"startcode"} .= "$code;\n";
}

# CHECK FOR GRAMMAR PROBLEMS....

sub _check_insatiable($$$$)
{
    my ($subrule,$repspec,$grammar,$line) = @_;
    pos($grammar)=pos($_[2]);
    return if $grammar =~ m/$OPTIONAL/gco || $grammar =~ m/$ANY/gco;
    my $min = 1;

    }
}

# GENERATE ACTUAL PARSER CODE

sub _code($)
{
    my $self = shift;
    my $initial_skip = defined($self->{skip}) ? $self->{skip} : $skip;

    my $code = qq!


    $ERRORS = 0;
    return $retval;
}

sub _parserepeat($$$$$$$$$)    # RETURNS A REF TO AN ARRAY OF MATCHES
{
    my ($parser, $text, $prod, $min, $max, $_noactions, $expectation, $argcode, $_itempos) = @_;
    my @tokens = ();

    my $itemposfirst;

    my $bar = '|';
    formline($TRACECONTEXT_FORMAT, $tracelevel, $tracerulename, $bar, $tracecontext, $tracecontext);
    print {*STDERR} $^A;
}

sub _verbosity($)
{
       defined $::RD_TRACE
    or defined $::RD_HINT    and  $::RD_HINT   and $_[0] =~ /ERRORS|WARN|HINT/
    or defined $::RD_WARN    and  $::RD_WARN   and $_[0] =~ /ERRORS|WARN/
    or defined $::RD_ERRORS  and  $::RD_ERRORS and $_[0] =~ /ERRORS/
}

sub _error($;$)
{
    $ERRORS++;
    return 0 if ! _verbosity("ERRORS");
    my $errortext   = $_[0];
    my $errorprefix = "ERROR" .  ($_[1] ? " (line $_[1])" : "");

    print {*STDERR} "\n" if _verbosity("WARN");
    _write_ERROR($errorprefix, $errortext);
    return 1;
}

sub _warn($$;$)
{
    return 0 unless _verbosity("WARN") && ($::RD_HINT || $_[0] >= ($::RD_WARN||1));
    my $errortext   = $_[1];
    my $errorprefix = "Warning" .  ($_[2] ? " (line $_[2])" : "");
    print {*STDERR} "\n" if _verbosity("HINT");
    $errortext =~ s/\s+/ /g;
    _write_ERROR($errorprefix, $errortext);
    return 1;
}

sub _hint($)
{
    return 0 unless $::RD_HINT;
    my $errortext = $_[0];
    my $errorprefix = "Hint" .  ($_[1] ? " (line $_[1])" : "");
    $errortext =~ s/\s+/ /g;
    _write_ERROR($errorprefix, $errortext);
    return 1;
}

sub _tracemax($)
{
    if (defined $::RD_TRACE
        && $::RD_TRACE =~ /\d+/
        && $::RD_TRACE>1
        && $::RD_TRACE+10<length($_[0]))

    {
        return substr($_[0],0,500);
    }
}

sub _tracefirst($)
{
    if (defined $::RD_TRACE
        && $::RD_TRACE =~ /\d+/
        && $::RD_TRACE>1
        && $::RD_TRACE+10<length($_[0]))


my $lastcontext = '';
my $lastrulename = '';
my $lastlevel = '';

sub _trace($;$$$)
{
    my $tracemsg      = $_[0];
    my $tracecontext  = $_[1]||$lastcontext;
    my $tracerulename = $_[2]||$lastrulename;
    my $tracelevel    = $_[3]||$lastlevel;

        }
    }
    $prefix . ($matched ? $t[0] : $t[1]) . $postfix;
}

sub _parseunneg($$$$$)
{
    _parse($_[0],$_[1],$_[3],$_[4]);
    if ($_[2]<0)
    {
        _error("Can't negate \"$_[4]\".",$_[3]);

        return 0;
    }
    return 1;
}

sub _parse($$$$)
{
    my $what = $_[3];
       $what =~ s/^\s+//;
    if ($_[1])
    {

    my $errorprefix = "Parse::RecDescent";
    $errortext =~ s/\s+/ /g;
    _write_ERROR($errorprefix, $errortext);
}

sub _linecount($) {
    scalar substr($_[0], pos $_[0]||0) =~ tr/\n//
}


package main;

view all matches for this distribution

Alt-App-makepatch

1 match

sub app_usage ($);
sub app_usage_filelist ($);
sub catfile ($$);
sub check_extract ($);
sub cleanup ();
sub cvs_excludes($$$);
sub cvs_ignore($);
sub debug   (@);
sub dodiff ($$$$);
sub makepatch ();
sub extract ($$);
sub filelist ($);

    rmtree ($tmpdir);
    die ("Okay\n") if $opt_test;
    exit (0);
}

sub shellpat($) {
    my ($pat) = (@_);
    my @a = split (/(\[[^\]]+\]|[*.?])/, $pat);
    join ('',
	  (map { ($_ eq '*' ? '.*' :
		  ($_ eq '?' ? '.' :

	$exclude_pat .= ')';
	debug ("Exclude pattern: $exclude_pat\n");
    }
}

sub cvs_ignore($) {
    my ($f) = @_;
    my $fh = do { local *F; *F; };
    unless ( open($fh, $f) ) {
	warn("$f: $!\n");
	return ();

    $pat =~ s/\s+$//;
    $pat =~ s/^\s+//;
    split(/\n/, $pat);
}

sub cvs_excludes($$$) {
    my ($f, $dir, $disp) = @_;

    my @list = cvs_ignore($f);
    return "" unless @list;

view all matches for this distribution

Alt-CWB-ambs

1 match

lib/CWB.pm view on Meta::CPAN

  else {
    return undef;
  }
}

sub add_attribute( $$$ ) {
  my ($self, $name, $type) = @_;
  die "CWB::RegistryFile: invalid attribute type '$type' for attribute $name\n"
      unless $type =~ /^[PpSsAa]$/;
  $type = lc $type;
  my $previous = $self->{ATT}->{$name};         # check if attribute is already defined

view all matches for this distribution

Alt-Devel-CallParser-ButWorking

7 results

lib/Devel/CallParser.pm view on Meta::CPAN

linking an XS module that uses the C functions supplied by this module.
This list will be empty on many platforms.

=cut

sub callparser_linkable() {
	require DynaLoader::Functions;
	DynaLoader::Functions->VERSION(0.001);
	return DynaLoader::Functions::linkable_for_module(__PACKAGE__);
}

view all matches for this distribution

Alt-Lexical-Var-ButSupportModernPerl

2 results

t/setup_code.t view on Meta::CPAN


BEGIN { $SIG{__WARN__} = sub { die "WARNING: $_[0]" }; }

require Lexical::Var;

sub test_case($) {
	my $result = eval($_[0]);
	my $err = $@;
	if($err eq "") {
		is $result, 123;
	} else {

t/setup_code.t view on Meta::CPAN

		}->()->();
	}
	&t9;
};

sub ts10() { "Lexical::Var"->import('&t10' => sub{123}); }
test_case q{
	BEGIN { ts10(); }
	&t10;
};

view all matches for this distribution

Alt-Math-Prime-FastSieve-Inline

1 match

                "vars"     => "",
            }, $class;
    }
}

sub reset($)
{
    @{$_[0]->{"prods"}} = ();
    @{$_[0]->{"calls"}} = ();
    $_[0]->{"changed"}  = 0;
    $_[0]->{"impcount"}  = 0;

    $_[0]->{"vars"}  = "";
}

sub DESTROY {}

sub hasleftmost($$)
{
    my ($self, $ref) = @_;

    my $prod;
    foreach $prod ( @{$self->{"prods"}} )

    }

    return 0;
}

sub leftmostsubrules($)
{
    my $self = shift;
    my @subrules = ();

    my $prod;

    }

    return @subrules;
}

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

    my $prod;

    }

    return join ', or ', @expected;
}

sub _contains($@)
{
    my $target = shift;
    my $item;
    foreach $item ( @_ ) { return 1 if $target eq $item; }
    return 0;
}

sub addcall($$)
{
    my ( $self, $subrule ) = @_;
    unless ( _contains($subrule, @{$self->{"calls"}}) )
    {
        push @{$self->{"calls"}}, $subrule;
    }
}

sub addprod($$)
{
    my ( $self, $prod ) = @_;
    push @{$self->{"prods"}}, $prod;
    $self->{"changed"} = 1;
    $self->{"impcount"} = 0;

    $self->{"autoscore"} = $code;
    $self->{"changed"} = 1;
    return 1;
}

sub nextoperator($)
{
    my $self = shift;
    my $prodcount = scalar @{$self->{"prods"}};
    my $opcount = ++$self->{"opcount"};
    return "_operator_${opcount}_of_production_${prodcount}_of_rule_$self->{name}";
}

sub nextimplicit($)
{
    my $self = shift;
    my $prodcount = scalar @{$self->{"prods"}};
    my $impcount = ++$self->{"impcount"};
    return "_alternation_${impcount}_of_production_${prodcount}_of_rule_$self->{name}";


    return $code;
}

my @left;
sub isleftrec($$)
{
    my ($self, $rules) = @_;
    my $root = $self->{"name"};
    @left = $self->leftmostsubrules();
    my $next;

    my ($self, $ref) = @_;
    return ${$self->{"items"}}[0] eq $ref  if scalar @{$self->{"items"}};
    return 0;
}

sub isempty($)
{
    my $self = shift;
    return 0 == @{$self->{"items"}};
}

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

    if ( $#{$self->{"items"}} >= 0 )
    {

    }

    return ();
}

sub checkleftmost($)
{
    my @items = @{$_[0]->{"items"}};
    if (@items==1 && ref($items[0]) =~ /\AParse::RecDescent::Error/
        && $items[0]->{commitonly} )
    {

        return 0;
    }
    return 1;
}

sub changesskip($)
{
    my $item;
    foreach $item (@{$_[0]->{"items"}})
    {
        if (ref($item) =~ /Parse::RecDescent::(Action|Directive)/)

        $itempos[$#itempos]{'line'}{'to'}   = $prevline;
        $itempos[$#itempos]{'column'}{'to'} = $prevcolumn;
    }
}

sub code($$$$)
{
    my ($self,$namespace,$rule,$parser) = @_;
    my $code =
'
    while (!$_matched'

}

sub issubrule { undef }
sub isterminal { 0 }

sub code($$$$)
{
    my ($self, $namespace, $rule) = @_;

'
        Parse::RecDescent::_trace(q{Trying action},

        "line"      => $_[3],
        "name"      => $_[4],
    }, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule) = @_;

'
        ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .'

}

# MARK, YOU MAY WANT TO OPTIMIZE THIS.


sub code($$$$)
{
    my ($self, $namespace, $rule) = @_;

'
        Parse::RecDescent::_trace(q{>>Rejecting production<< (found '

        "commitonly" => $_[3],
        "line"       => $_[4],
    }, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule) = @_;

    my $action = '';

        "description" => $desc,
    }, $class;
}


sub code($$$$$)
{
    my ($self, $namespace, $rule, $check) = @_;
    my $ldel = $self->{"ldelim"};
    my $rdel = $self->{"rdelim"};
    my $sdel = $ldel;

        "description" => "'$desc'",
    }, $class;
}


sub code($$$$)
{
    my ($self, $namespace, $rule, $check) = @_;

my $code = '
        Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe

        "line"      => $_[3],
        "description" => "'$desc'",
    }, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule, $check) = @_;

my $code = '
        Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe

    my $desc = $_[0]->{"implicit"} || $_[0]->{"subrule"};
    $desc = "<matchrule:$desc>" if $_[0]->{"matchrule"};
    return $desc;
}

sub callsyntax($$)
{
    if ($_[0]->{"matchrule"})
    {
        return "&{'$_[1]'.qq{$_[0]->{subrule}}}";
    }

        "argcode"   => $_[6] || undef,
    }, $class;
}


sub code($$$$)
{
    my ($self, $namespace, $rule, $check) = @_;

'
        Parse::RecDescent::_trace(q{Trying subrule: [' . $self->{"subrule"} . ']},

    my $desc = $_[0]->{"expected"} || $_[0]->{"subrule"};
    $desc = "<matchrule:$desc>" if $_[0]->{"matchrule"};
    return $desc;
}

sub callsyntax($$)
{
    if ($_[0]->{matchrule})
        { return "sub { goto &{''.qq{$_[1]$_[0]->{subrule}}} }"; }
    else
        { return "\\&$_[1]$_[0]->{subrule}"; }

        "argcode"   => $argcode || undef,
        "matchrule" => $matchrule,
    }, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule, $check) = @_;

    my ($subrule, $repspec, $min, $max, $lookahead) =
        @{$self}{ qw{subrule repspec min max lookahead} };

    my ($class, $pos) = @_;

    bless {}, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule) = @_;

    '
        $return = $item[-1];

        "rightarg"  => $rightarg,
        "expected"  => "<${type}op: ".$leftarg->describe." ".$op->describe." ".$rightarg->describe.">",
    }, $class;
}

sub code($$$$)
{
    my ($self, $namespace, $rule, $check) = @_;

    my @codeargs = @_[1..$#_];


# BUILDING A PARSER

my $nextnamespace = "namespace000001";

sub _nextnamespace()
{
    return "Parse::RecDescent::" . $nextnamespace++;
}

# ARGS ARE: $class, $grammar, $compiling, $namespace


    bless $self, $class;
    return $self->Replace($_[1])
}

sub Compile($$$$) {
    die "Compilation of Parse::RecDescent grammars not yet implemented\n";
}

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

    if ($ERRORS) { $ERRORS=0; return }
    return $self;
}


sub _addstartcode($$)
{
    my ($self, $code) = @_;
    $code =~ s/\A\s*\{(.*)\}\Z/$1/s;

    $self->{"startcode"} .= "$code;\n";
}

# CHECK FOR GRAMMAR PROBLEMS....

sub _check_insatiable($$$$)
{
    my ($subrule,$repspec,$grammar,$line) = @_;
    pos($grammar)=pos($_[2]);
    return if $grammar =~ m/$OPTIONAL/gco || $grammar =~ m/$ANY/gco;
    my $min = 1;

    }
}

# GENERATE ACTUAL PARSER CODE

sub _code($)
{
    my $self = shift;
    my $initial_skip = defined($self->{skip}) ? $self->{skip} : $skip;

    my $code = qq!


    $ERRORS = 0;
    return $retval;
}

sub _parserepeat($$$$$$$$$)    # RETURNS A REF TO AN ARRAY OF MATCHES
{
    my ($parser, $text, $prod, $min, $max, $_noactions, $expectation, $argcode, $_itempos) = @_;
    my @tokens = ();

    my $itemposfirst;

    my $bar = '|';
    formline($TRACECONTEXT_FORMAT, $tracelevel, $tracerulename, $bar, $tracecontext, $tracecontext);
    print {*STDERR} $^A;
}

sub _verbosity($)
{
       defined $::RD_TRACE
    or defined $::RD_HINT    and  $::RD_HINT   and $_[0] =~ /ERRORS|WARN|HINT/
    or defined $::RD_WARN    and  $::RD_WARN   and $_[0] =~ /ERRORS|WARN/
    or defined $::RD_ERRORS  and  $::RD_ERRORS and $_[0] =~ /ERRORS/
}

sub _error($;$)
{
    $ERRORS++;
    return 0 if ! _verbosity("ERRORS");
    my $errortext   = $_[0];
    my $errorprefix = "ERROR" .  ($_[1] ? " (line $_[1])" : "");

    print {*STDERR} "\n" if _verbosity("WARN");
    _write_ERROR($errorprefix, $errortext);
    return 1;
}

sub _warn($$;$)
{
    return 0 unless _verbosity("WARN") && ($::RD_HINT || $_[0] >= ($::RD_WARN||1));
    my $errortext   = $_[1];
    my $errorprefix = "Warning" .  ($_[2] ? " (line $_[2])" : "");
    print {*STDERR} "\n" if _verbosity("HINT");
    $errortext =~ s/\s+/ /g;
    _write_ERROR($errorprefix, $errortext);
    return 1;
}

sub _hint($)
{
    return 0 unless $::RD_HINT;
    my $errortext = $_[0];
    my $errorprefix = "Hint" .  ($_[1] ? " (line $_[1])" : "");
    $errortext =~ s/\s+/ /g;
    _write_ERROR($errorprefix, $errortext);
    return 1;
}

sub _tracemax($)
{
    if (defined $::RD_TRACE
        && $::RD_TRACE =~ /\d+/
        && $::RD_TRACE>1
        && $::RD_TRACE+10<length($_[0]))

    {
        return substr($_[0],0,500);
    }
}

sub _tracefirst($)
{
    if (defined $::RD_TRACE
        && $::RD_TRACE =~ /\d+/
        && $::RD_TRACE>1
        && $::RD_TRACE+10<length($_[0]))


my $lastcontext = '';
my $lastrulename = '';
my $lastlevel = '';

sub _trace($;$$$)
{
    my $tracemsg      = $_[0];
    my $tracecontext  = $_[1]||$lastcontext;
    my $tracerulename = $_[2]||$lastrulename;
    my $tracelevel    = $_[3]||$lastlevel;

        }
    }
    $prefix . ($matched ? $t[0] : $t[1]) . $postfix;
}

sub _parseunneg($$$$$)
{
    _parse($_[0],$_[1],$_[3],$_[4]);
    if ($_[2]<0)
    {
        _error("Can't negate \"$_[4]\".",$_[3]);

        return 0;
    }
    return 1;
}

sub _parse($$$$)
{
    my $what = $_[3];
       $what =~ s/^\s+//;
    if ($_[1])
    {

    my $errorprefix = "Parse::RecDescent";
    $errortext =~ s/\s+/ /g;
    _write_ERROR($errorprefix, $errortext);
}

sub _linecount($) {
    scalar substr($_[0], pos $_[0]||0) =~ tr/\n//
}


package main;

view all matches for this distribution

Alt-Module-Runtime-ButEUMM

5 results

	}
}

# Logic duplicated from Params::Classify.  Duplicating it here avoids
# an extensive and potentially circular dependency graph.
sub _is_string($) {
	my($arg) = @_;
	return defined($arg) && ref(\$arg) eq "SCALAR";
}

=head1 REGULAR EXPRESSIONS

Returns a truth value indicating whether I<ARG> is a plain string
satisfying Perl module name syntax as described for L</$module_name_rx>.

=cut

sub is_module_name($) { _is_string($_[0]) && $_[0] =~ /\A$module_name_rx\z/o }

=item is_valid_module_name(ARG)

Deprecated alias for L</is_module_name>.

satisfying Perl module name syntax as described for L</$module_name_rx>.
Return normally if it is, or C<die> if it is not.

=cut

sub check_module_name($) {
	unless(&is_module_name) {
		die +(_is_string($_[0]) ? "`$_[0]'" : "argument").
			" is not a module name\n";
	}
}

C<require>, and is the key that appears in C<%INC> to identify a module,
regardless of actual local filename syntax.

=cut

sub module_notional_filename($) {
	&check_module_name;
	my($name) = @_;
	$name =~ s!::!/!g;
	return $name.".pm";
}

		delete $INC{$_[0]->[0]} if @{$_[0]};
	}
	1;
}; die $@ if $@ ne ""; } }

sub require_module($) {
	# Localise %^H to work around [perl #68590], where the bug exists
	# and this is a satisfactory workaround.  The bug consists of
	# %^H state leaking into each required module, polluting the
	# module's lexical state.
	local %^H if _WORK_AROUND_HINT_LEAKAGE;

can be used as a class name to call a constructor, as in the example in
the synopsis.

=cut

sub use_module($;$) {
	my($name, $version) = @_;
	require_module($name);
	$name->VERSION($version) if @_ >= 2;
	return $name;
}

On success, the name of the package is returned.  These aspects of the
function work just like L</use_module>.

=cut

sub use_package_optimistically($;$) {
	my($name, $version) = @_;
	my $fn = module_notional_filename($name);
	eval { local $SIG{__DIE__}; require_module($name); };
	die $@ if $@ ne "" &&
		($@ !~ /\ACan't locate \Q$fn\E .+ at \Q@{[__FILE__]}\E line/s ||

the validity of I<SPEC>, but the exact value of the prefix is unimportant,
so this function treats I<PREFIX> as a truth value.

=cut

sub is_module_spec($$) {
	my($prefix, $spec) = @_;
	return _is_string($spec) &&
		$spec =~ ($prefix ? qr/\A$sub_module_spec_rx\z/o :
				    qr/\A$top_module_spec_rx\z/o);
}

Check whether I<SPEC> is valid input for L</compose_module_name>.
Return normally if it is, or C<die> if it is not.

=cut

sub check_module_spec($$) {
	unless(&is_module_spec) {
		die +(_is_string($_[1]) ? "`$_[1]'" : "argument").
			" is not a module specification\n";
	}
}

The user can inhibit the prefix addition by starting I<SPEC> with a
separator (either C</> or C<::>).

=cut

sub compose_module_name($$) {
	my($prefix, $spec) = @_;
	check_module_name($prefix) if defined $prefix;
	&check_module_spec;
	if($spec =~ s#\A(?:/|::)##) {
		# OK

view all matches for this distribution

Alt-Sub-Delete-NewPackageSeparator

2 results

lib/Sub/Delete.pm view on Meta::CPAN


use Exporter 5.57 'import';
use constant point0 => 0+$] eq 5.01;

# This sub must come before any lexical vars.
sub strict_eval($) {
 local %^H if point0;
 local *@;
 use#
  strict 'vars';
 local $SIG{__WARN__} = sub {};

view all matches for this distribution

Alvis-Bags

4 results

lib/Alvis/URLs.pm view on Meta::CPAN

#  URL switches
$Alvis::URLs::nocase = 0;
$Alvis::URLs::noclean = 0;
$Alvis::URLs::keepfrag = 0;

sub CleanURL() {
  if ( !$_[0] ) {
	return undef;
  }
  my $uri = new URI($_[0]);
  if ( ! $Alvis::URLs::keepfrag ) {
    $uri->fragment(undef);
  }
  return $uri->canonical;
}

sub StandardURL() {
  my $inu = shift();
  if ( $Alvis::URLs::nocase ) {
    $inu = lc($inu);
  }
  if ( $Alvis::URLs::noclean == 0 ) {

view all matches for this distribution

Alvis-Convert

2 results

lib/Alvis/Buffer.pm view on Meta::CPAN

our $verbose = 0;

############################################
#
#  add XML chunk
sub add() {
  my $xml = shift();
  my $xc = $xml;
  my $count = $xc =~ s/<\/documentRecord>//g;
  #  now save
  print ABUF $xml,"\n";

lib/Alvis/Buffer.pm view on Meta::CPAN

  }
  $docs += $count;
  $size += length($xml);
}

sub close() {
  CORE::close(ABUF);
}

############################################
#
#  make sure the output XML buffer file is in OK state
#  and open it for append, as filehandle ABUF
#  and set $docs, $size
#  return 0 on fatal error, after printing error message
sub fix() {
  $docs = 0;
  $size = 0;
  if ( ! -f $BUFFER ) {
    #  start new one
    if ( ! open(ABUF,">>$BUFFER") ) {

lib/Alvis/Buffer.pm view on Meta::CPAN

############################################
#
#  rename output XML buffer file to xml-add/N.xml for some N
#  and create a new output XML buffer file, name is returned;
#  return undef on fatal error, after printing error message
sub save() {
  print ABUF $TRAILER; 
  CORE::close(ABUF);
  #  determine next available name
  if ( ! opendir(XA,"xml-add") ) {
    print STDERR "Cannot opendir xml-add/: $!\n";

view all matches for this distribution

Alvis-NLPPlatform

1 match

lib/Alvis/NLPPlatform.pm view on Meta::CPAN

}


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

sub starttimer(){
    my $sec;
    my $usec;
    ($sec,$usec)=gettimeofday();
    $usec/=1000000;
    $timer_mem=($sec+$usec);
}



sub endtimer(){
    my $sec;
    my $usec;
    ($sec,$usec)=gettimeofday();
    $usec/=1000000;
    return (($sec+$usec)-$timer_mem);

view all matches for this distribution

Alvis-QueryFilter

3 results

bin/run_QF.pl view on Meta::CPAN

    s/[\-_]//g;
  }
  return $_;
}

sub cleanspaces() {
  $_ = shift();
  s/\s+/ /g;
  s/^ //g;
  s/ $//g;
  return $_;
}

sub checkdict() {
  my $f = shift();
  my $canonise = shift();
  my %dict = ();
  my %line = ();

bin/run_QF.pl view on Meta::CPAN

  undef($c);
}
print STDERR "SRU query transformer shut down\n";
exit(1); 

sub processSRU() {
  my $SRU = shift();

  if ( $verbose ) {
    print STDERR "SRU: $SRU\n\n";
  }

bin/run_QF.pl view on Meta::CPAN

  } 
  
  return $response;
}

sub readargs() {
  if ( ! open(A,"<$ALVISHOME/alvis.cnf") ) {
    print STDERR "No alvis.cnf: $!\n";
    exit(1);
  }
  while ( ($_=<A>) ) {

view all matches for this distribution

Alvis-Saa

1 match

#
#  Public methods
#
###################################################################

sub error($)
{
    my ($client) = @_;
    return $ERROR{$client};
}

sub readname($)
{
    my ($client) = @_;

    my $len = readnum($client);
    if(!defined($len))

    }
    
    return $name;
}

sub readnum($)
{
    my ($client) = @_;

    my $got = 0;
    my $num = '';

#    warn "Alvis::Tana::readnum() read num $num";
    
    return $num;
}

sub readbytes($$)
{
    my ($client, $len) = @_;

    my $str = '';

#    warn "Alvis::Tana::readbytes(): read $str";
    
    return ($str,$got);
}

sub read_field_header($)
{
    my ($client) = @_;

    my $keylen = readnum($client);
    if(!defined($keylen))

    }

    return $msg;
}

sub read_arb($$$)
{
    my ($client, $len, $eof) = @_;

    my $str = '';


    return $str;
}


sub write_arb($$$)
{
    my ($client, $str, $final) = @_;

    while(length($str) > 0)
    {

    }

    return 1;
}

sub write($$$)
{
    my ($client, $msg, $type) = @_;

    my @keys = keys(%$msg);
    my $fieldc = scalar(@keys);

view all matches for this distribution

Alvis-TermTagger

1 match

lib/Alvis/TermTagger.pm view on Meta::CPAN


#########################################################################################################
    warn "\nEnd of term tagging\n";
}

sub printMatchingTerm() {
    my ($descriptor, $ref_matching_term, $sent_id) = @_;

    print $descriptor "$sent_id\t";
    print $descriptor join("\t", @$ref_matching_term);
    print $descriptor "\n";

lib/Alvis/TermTagger.pm view on Meta::CPAN

    close TAGGEDCORPUS;
#########################################################################################################
    warn "\nEnd of term tagging\n";
}

sub print_brat_output() {
    my ($descriptor, $termId, $matching_term, $start_offset, $end_offset, $semtag) = @_;

    if ((!defined $semtag) || ($semtag =~ /^\s*$/)) {
	$semtag = "term";
    }

lib/Alvis/TermTagger.pm view on Meta::CPAN

    print $descriptor "T$$termId\t$semtag $start_offset $end_offset\t$matching_term\n";
    $$termId++;
}


sub printMatchingTerm_tab() {
    my ($ref_matching_term, $term, $sent_id, $ref_tab_results) = @_;

    my $tmp_line = "";
    my $tmp_key;

view all matches for this distribution

Amazon-SQS-Client

1 match

}

#
# Convert CreateQueueRequest to name value pairs
#
sub _convertCreateQueue() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'CreateQueue';

}

#
# Convert ListQueuesRequest to name value pairs
#
sub _convertListQueues() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'ListQueues';

}

#
# Convert ListDeadLetterSourceQueues to name value pairs
#
sub _convertListDeadLetterSourceQueues() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'ListDeadLetterSourceQueues';

}

#
# Convert ChangeMessageVisibilityRequest to name value pairs
#
sub _convertChangeMessageVisibility() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'ChangeMessageVisibility';

  }

  return $parameters;
}

sub _convertChangeMessageVisibilityBatch() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'ChangeMessageVisibilityBatch';

}

#
# Convert DeleteMessageRequest to name value pairs
#
sub _convertDeleteMessage() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'DeleteMessage';
  if ( $request->isSetQueueUrl() ) {

  }

  return $parameters;
}

sub _convertDeleteMessageBatch() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'DeleteMessageBatch';
  if ( $request->isSetQueueUrl() ) {

}

#
# Convert DeleteQueueRequest to name value pairs
#
sub _convertDeleteQueue() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'DeleteQueue';

}

#
# Convert GetQueueAttributesRequest to name value pairs
#
sub _convertGetQueueAttributes() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'GetQueueAttributes';
  if ( $request->isSetQueueUrl() ) {

}

#
# Convert ReceiveMessageRequest to name value pairs
#
sub _convertReceiveMessage() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'ReceiveMessage';
  if ( $request->isSetQueueUrl() ) {

}

#
# Convert SendMessageRequest to name value pairs
#
sub _convertSendMessage() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'SendMessage';
  if ( $request->isSetQueueUrl() ) {

}

#
# Convert SetQueueAttributesRequest to name value pairs
#
sub _convertSetQueueAttributes() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'SetQueueAttributes';
  if ( $request->isSetQueueUrl() ) {

}

#
# Convert AddPermissionRequest to name value pairs
#
sub _convertAddPermission() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'AddPermission';

}

#
# Convert RemovePermissionRequest to name value pairs
#
sub _convertRemovePermission() {
  my ( $self, $request ) = @_;

  my $parameters = {};
  $parameters->{Action} = 'RemovePermission';
  if ( $request->isSetQueueUrl() ) {

view all matches for this distribution

Amazon-Sites

1 match

lib/Amazon/Sites.pm view on Meta::CPAN

  } values %sites;

  return @sites;
}

sub _init_sites($assoc_codes, $include, $exclude) {
  my %sites;
  my @cols = qw[code country tldn currency sort];

  my $where = tell DATA;

view all matches for this distribution

Amb

1 match

Amb.pm view on Meta::CPAN

		}
	}
	undef $charged;
}

sub fail($)
{
	local $Carp::CarpLevel = 3 unless $debug;
	confess "Can't call $_[0]\(\) that way";
}

view all matches for this distribution

Ambrosia

14 results

lib/Ambrosia/Assert.pm view on Meta::CPAN

        *{"${package_instance}::assert"} = sub(&$) {};
    }

}

sub __assert(&$)
{
    my $condition = shift;
    if (( ref $condition eq 'CODE' && !$condition->() ) || !$condition)
    {
        carp( 'error: ' . shift);

view all matches for this distribution

Amon2

1 match