view release on metacpan or search on metacpan
eg/mod_auth_token_example.pl view on Meta::CPAN
use Carp;
use Getopt::Long;
use Authen::ModAuthToken qw/generate_mod_auth_token/;
use File::Basename;
sub show_help();
my $server = "http://my.server.com";
my $prefix = "/protected";
my $secret = "FlyingMoneys";
my $file = undef;
eg/mod_auth_token_example.pl view on Meta::CPAN
my $url = $server . $prefix . $token ;
print $url, "\n";
sub show_help()
{
my $base=basename($0);
print<<EOF;
Authen::ModAuthToken example
Copyright (C) 2012 by A. Gordon <gordon at cshl.edu>
view release on metacpan or search on metacpan
lib/Authen/NTLM/HTTP.pm view on Meta::CPAN
# http_negotiate creates a NTLM-over-HTTP tag line for NTLM #
# negotiate packet given the domain (from Win32::DomainName()) and #
# the workstation name (from $ENV{'COMPUTERNAME'} or #
# Win32::NodeName()) and the negotiation flags. #
####################################################################
sub http_negotiate($$)
{
my $self = shift;
my $flags = shift;
my $str = encode_base64($self->SUPER::negotiate_msg($flags));
$str =~ s/\s//g;
lib/Authen/NTLM/HTTP.pm view on Meta::CPAN
###########################################################################
# http_parse_negotiate parses the NTLM-over-HTTP negotiate tag line and #
# return a list of NTLM Negotiation Flags, Server Network Domain and #
# Machine name of the client. #
###########################################################################
sub http_parse_negotiate($$)
{
my ($self, $pkt) = @_;
$pkt =~ s/Authorization: NTLM //;
my $str = decode_base64($pkt);
return $self->SUPER::parse_negotiate($str);
lib/Authen/NTLM/HTTP.pm view on Meta::CPAN
####################################################################
# http_challenge composes the NTLM-over-HTTP challenge tag line. It#
# takes NTLM Negotiation Flags as an argument. #
####################################################################
sub http_challenge($$)
{
my $self = $_[0];
my $flags = $_[1];
my $nonce = undef;
my $str;
lib/Authen/NTLM/HTTP.pm view on Meta::CPAN
# the server. It takes 2 arguments: $nonce obtained from parse_challenge #
# and NTLM Negotiation Flags. This function ASSUMEs the input of user #
# domain, user name and workstation name are in ASCII format and not in #
# UNICODE format. #
###########################################################################
sub http_auth($$$)
{
my $self = shift;
my $nonce = shift;
my $flags = shift;
my $str = encode_base64($self->SUPER::auth_msg($nonce, $flags));
lib/Authen/NTLM/HTTP.pm view on Meta::CPAN
###########################################################################
# http_parse_auth parses the NTLM-over-HTTP authentication tag line and #
# return a list of NTLM Negotiation Flags, LM response, NT response, User #
# Domain, User Name, User Machine Name and Session Key. #
###########################################################################
sub http_parse_auth($$)
{
my ($self, $pkt) = @_;
if ($self->{'type'} eq NTLMSSP_HTTP_PROXY) {
$pkt =~ s/Proxy-Authorization: NTLM //;
}
view release on metacpan or search on metacpan
lib/Authen/Passphrase/EggdropBlowfish.pm view on Meta::CPAN
use parent "Authen::Passphrase";
my $b64_digits =
"./0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
sub _en_base64($) {
my($bytes) = @_;
my $digits = "";
foreach my $word (reverse unpack("N*", $bytes)) {
for(my $i = 6; $i--; $word >>= 6) {
$digits .= substr($b64_digits, $word & 0x3f, 1);
}
}
return $digits;
}
sub _de_base64($) {
my($digits) = @_;
my @words;
while($digits =~ /(......)/sg) {
my $wdig = $1;
my $word = 0;
view release on metacpan or search on metacpan
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
use constant NTLMSSP_NEGOTIATE_TARGET_INFO => 0x00800000;
use constant NTLMSSP_NEGOTIATE_128 => 0x20000000;
use constant NTLMSSP_NEGOTIATE_KEY_EXCH => 0x40000000;
use constant NTLMSSP_NEGOTIATE_80000000 => 0x80000000;
sub lm_hash($);
sub nt_hash($);
sub calc_resp($$);
#########################################################################
# Constructor to initialize authentication related information. In this #
# version, we assume NTLM as the authentication scheme of choice. #
# The constructor takes the class name, LM hash of the client password #
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
##########################################################################
# lm_hash calculates the LM hash to be used to calculate the LM response #
# It takes a password and return the 21 bytes LM password hash. #
##########################################################################
sub lm_hash($)
{
my ($passwd) = @_;
my $cipher1;
my $cipher2;
my $magic = pack("H16", "4B47532140232425"); # magical string to be encrypted for the LM password hash
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
##########################################################################
# nt_hash calculates the NT hash to be used to calculate the NT response #
# It takes a password and return the 21 bytes NT password hash. #
##########################################################################
sub nt_hash($)
{
my ($passwd) = @_;
my $nt_pw = unicodify($passwd);
my $nt_hpw;
if ($Authen::Perl::NTLM::PurePerl == 1) {
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
# negotiate_msg creates the NTLM negotiate packet given the domain #
# (from Win32::DomainName()) and the workstation name (from #
# $ENV{'COMPUTERNAME'} or Win32::NodeName()) and the negotiation #
# flags. #
####################################################################
sub negotiate_msg($$)
{
my $self = $_[0];
my $flags = pack("V", $_[1]);
my $domain = $self->{'domain'};
my $machine = $self->{'machine'};
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
####################################################################
# challenge_msg composes the NTLM challenge message. It takes NTLM #
# Negotiation Flags as an argument. #
####################################################################
sub challenge_msg($)
{
my ($self) = @_;
my $flags = pack("V", $_[1]);
my $domain = $self->{'domain'};
my $msg = NTLMSSP_SIGNATURE . chr(0);
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
# server. It takes 2 arguments: $nonce obtained from parse_challenge and #
# NTLM Negotiation Flags. #
# This function ASSUMEs the input of user domain, user name and #
# workstation name are in ASCII format and not in UNICODE format. #
###########################################################################
sub auth_msg($$$)
{
my ($self, $nonce) = @_;
my $session_key = session_key();
my $user_domain = $self->{'user_domain'};
my $username = $self->{'user'};
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
#######################################################################
# compute_nonce computes the 8-bytes nonce to be included in server's
# NTLM challenge packet.
#######################################################################
sub compute_nonce($)
{
my ($cChallenge) = @_;
my @SysTime = UNIXTimeToFILETIME($cChallenge, time);
my $Seed = (($SysTime[1] + 1) << 0) |
(($SysTime[2] + 0) << 8) |
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
#########################################################################
# convert_key converts a 7-bytes key to an 8-bytes key based on an
# algorithm.
#########################################################################
sub convert_key($) {
my ($in_key) = @_;
my @byte;
my $result = "";
usage("exactly 7-bytes key") unless length($in_key) == 7;
$byte[0] = substr($in_key, 0, 1);
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
##########################################################################
# set_odd_parity turns one-byte into odd parity. Odd parity means that
# a number in binary has odd number of 1's.
##########################################################################
sub set_odd_parity($)
{
my ($byte) = @_;
my $parity = 0;
my $ordbyte;
usage("single byte input only") unless length($byte) == 1;
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
###########################################################################
# calc_resp computes the 24-bytes NTLM response based on the password hash
# and the nonce.
###########################################################################
sub calc_resp($$)
{
my ($key, $nonce) = @_;
my $cipher1;
my $cipher2;
my $cipher3;
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
}
#########################################################################
# unicodify takes an ASCII string and turns it into a unicode string.
#########################################################################
sub unicodify($)
{
my ($str) = @_;
my $newstr = "";
my $i;
lib/Authen/Perl/NTLM.pm view on Meta::CPAN
# in win32 platforms. It returns two 32-bit integer. The first one is
# the upper 32-bit and the second one is the lower 32-bit. The result is
# adjusted by cChallenge as in NTLM spec. For those of you who want to
# use this function for actual use, please remove the cChallenge variable.
##########################################################################
sub UNIXTimeToFILETIME($$)
{
my ($cChallenge, $time) = @_;
$time = $time * 10000000 + 11644473600000000 + $cChallenge;
my $uppertime = $time / (2**32);
my $lowertime = $time - floor($uppertime) * 2**32;
view release on metacpan or search on metacpan
lib/Authen/Pluggable.pm view on Meta::CPAN
our $AUTOLOAD;
$AUTOLOAD =~ s/.*:://;
return $s->_providers->{$AUTOLOAD};
}
sub provider($s, $provider, $plugin=undef) {
$plugin //= $provider;
my %v = (provider => $plugin);
$s->_load_provider($provider, provider => $plugin)
unless exists($s->_providers->{$provider});
return $s->_providers->{$provider};
view release on metacpan or search on metacpan
inc/Test/More.pm view on Meta::CPAN
}
#line 424
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
$tb->cmp_ok(@_);
}
view release on metacpan or search on metacpan
lib/Authorization/AccessControl.pm view on Meta::CPAN
use Exporter 'import';
our @EXPORT_OK = qw(acl);
sub acl() {
state $acl = Authorization::AccessControl::ACL->new();
$acl;
}
=head1 NAME
view release on metacpan or search on metacpan
lib/Aws/Polly/Select.pm view on Meta::CPAN
eval $s;
$@ and confess $@;
}
}
sub fieldValues($) # All the values a specified field can take
{my ($field) = @_;
my %l;
my @s = @{&speakerDetails};
for my $speaker(@s)
{if (my $v = $speaker->{$field})
lib/Aws/Polly/Select.pm view on Meta::CPAN
#-------------------------------------------------------------------------------
# Select speakers
#-------------------------------------------------------------------------------
sub speaker(@) # Select speakers by fields
{my (%selection) = @_; # Selection fields: name=>"regular expression" where the field of that name must match the regular expression regardless of case
my @s;
for my $speaker(@{&speakerDetails}) # Check each speaker
{my $m = 1; # Speaker matches so far
for my $field(keys %selection) # Continue with the speaker as long as they match on all the supplied fields - these fields are our shorter simpler names not AWS's longer more complicated names
view release on metacpan or search on metacpan
lib/AxKit2/Transformer/XSP.pm view on Meta::CPAN
]egx;
return "AxKit2::Transformer::XSP::ROOT$filename";
}
sub makeSingleQuoted($) {
my $value = shift;
$value =~ s/([\\|])/\\$1/g;
return 'q|'.$value.'|';
}
view release on metacpan or search on metacpan
lib/B/Assembler.pm view on Meta::CPAN
sub quiet { $quiet = shift }
my ( $maxopix, $maxsvix ) = ( 0xffffffff, 0xffffffff );
sub maxopix { $maxopix = shift }
sub maxsvix { $maxsvix = shift }
sub limcheck($$$$) {
my ( $val, $lo, $hi, $loc ) = @_;
if ( $val < $lo || $hi < $val ) {
error "argument for $loc outside [$lo, $hi]: $val";
$val = $hi;
}
view release on metacpan or search on metacpan
my @z = ();
my @a = qw(a);
my @b = qw(a b);
my @c = qw(a b c);
sub foo($$) { [@_] }
sub bar(@) { [@_] }
my($ckfun, $ckobj);
is_deeply scalar(eval(q{foo(@b, @c)})), [ 2, 3 ];
is scalar(@{[cv_get_call_checker(\&foo)]}), 2;
($ckfun, $ckobj) = cv_get_call_checker(\&foo);
ok $ckfun == \&ck_entersub_args_proto_or_list;
is_deeply $ckobj, \"\$\@";
is_deeply scalar(eval(q{foo(@b, @c)})), [ 2, qw(a b c) ];
my($scalars_called, $scalars_namegv, $scalars_ckobj, $scalars_argcount);
sub ckfun_scalars($$$) {
my($entersubop, $namegv, $ckobj) = @_;
$scalars_called++;
$scalars_namegv = $namegv;
$scalars_ckobj = $ckobj;
my $pushop = $entersubop->first;
is scalar(@{[cv_get_call_checker(\&foo)]}), 2;
($ckfun, $ckobj) = cv_get_call_checker(\&foo);
ok $ckfun == \&ck_entersub_args_proto_or_list;
ok $ckobj == \&bar;
sub ckfun_lists($$$) {
my($entersubop, $namegv, $ckobj) = @_;
return ck_entersub_args_list($entersubop);
}
cv_set_call_checker(\&foo, \&ckfun_lists, \&foo);
view release on metacpan or search on metacpan
examples/dolines.pl view on Meta::CPAN
use File::Basename;
use File::Spec;
my $dir = dirname(__FILE__);
my $libdir = File::Spec->catfile($dir, '..', 'lib');
# Something to make sure we are recursing subroutines.
sub five() {
5
}
my $file;
if (scalar @ARGV) {
$file = shift @ARGV;
view release on metacpan or search on metacpan
example/fib.pl view on Meta::CPAN
use B::DeparseTree;
use B::Deparse;
use Data::Printer;
use B::Concise;
sub fib($) {
my $x = shift;
return 1 if $x <= 1;
fib($x-1) + fib($x-2);
}
view release on metacpan or search on metacpan
our $x;
BEGIN { $x = "BEGIN { is(B::Hooks::Parser::get_linestr(), \$x); }\n" }
BEGIN { is(B::Hooks::Parser::get_linestr(), $x); }
sub eval_test($) {
my($src) = @_;
$x = undef;
is eval($src), 1;
like $x, qr/^\Q$src\E(?:\n;)?/;
}
view release on metacpan or search on metacpan
lib/B/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 release on metacpan or search on metacpan
lib/B/Tools.pm view on Meta::CPAN
use parent qw(Exporter);
our @EXPORT = qw(op_grep op_walk op_descendants);
sub op_walk(&$) {
my ($code, $op) = @_;
local *B::OP::walkoptree_simple = sub {
local $_ = $_[0];
$code->();
};
B::walkoptree($op, 'walkoptree_simple');
}
sub op_grep(&$) {
my ($code, $op) = @_;
my @ret;
op_walk {
if ($code->()) {
lib/B/Tools.pm view on Meta::CPAN
}
} $op;
return @ret;
}
sub op_descendants($) {
my $op = shift;
my @result;
op_walk {
push @result, $_;
} $op;
view release on metacpan or search on metacpan
t/utils/30parent.t view on Meta::CPAN
# );
# B::Concise::compile("test_data")->();
# FIXME: Consider moving this into B::Utils. But consider warning about
# adding to B::OPS and B::Concise.
sub has_branch($)
{
my $op = shift;
return ref($op) and $$op and ($op->flags & OPf_KIDS);
}
view release on metacpan or search on metacpan
t/30parent.t view on Meta::CPAN
# );
# B::Concise::compile("test_data")->();
# FIXME: Consider moving this into B::Utils1. But consider warning about
# adding to B::OPS and B::Concise.
sub has_branch($)
{
my $op = shift;
return ref($op) and $$op and ($op->flags & OPf_KIDS);
}
view release on metacpan or search on metacpan
lib/BBCode/Body.pm view on Meta::CPAN
use BBCode::Util qw(multilineText);
use strict;
use warnings;
our $VERSION = '0.34';
sub Tag($):method {
return 'BODY';
}
sub BodyPermitted($):method {
return 1;
}
sub BodyTags($):method {
return qw(:ALL BODY);
}
sub bodyHTML($):method {
return BBCode::Tag::Block::bodyHTML(shift);
}
sub toBBCode($):method {
my $this = shift;
my $ret = "";
foreach($this->body) {
$ret .= $_->toBBCode;
}
return multilineText $ret;
}
sub toHTML($):method {
my $this = shift;
my $pfx = $this->parser->css_prefix;
my $body = $this->bodyHTML;
return multilineText qq(<div class="${pfx}body">\n$body\n</div>\n);
}
view release on metacpan or search on metacpan
lib/BDB/Wrapper.pm view on Meta::CPAN
If you set {'transaction'=>transaction_root_dir}, all dbh object will be created in transaction mode unless you don\'t specify transaction root dir in each method.
0 is default value.
=cut
sub new(){
my $self={};
my $class=shift;
my $op_ref=shift;
$self->{'lock_root'}='/tmp/bdbwrapper';
$self->{'no_lock'}=0;
lib/BDB/Wrapper.pm view on Meta::CPAN
no_lock and cache will overwrite the value specified in new but used only in this env
=cut
sub create_env(){
my $self=shift;
my $op=shift;
my $bdb=File::Spec->rel2abs($op->{'bdb'}) || return;
my $no_lock=$op->{'no_lock'} || $self->{'no_lock'} || 0;
my $transaction=undef;
lib/BDB/Wrapper.pm view on Meta::CPAN
Creates database handler for BerkeleyDB
This will be obsolete due to too much simplicity, so please don\'t use.
=cut
sub create_dbh(){
my $self=shift;
my $bdb=File::Spec->rel2abs(shift);
my $op=shift;
return $self->create_write_dbh($bdb,$op);
}
lib/BDB/Wrapper.pm view on Meta::CPAN
Creates database handler for BerkeleyDB
This will be obsolete due to too much simplicity, so please don\'t use.
=cut
sub create_hash_ref(){
my $self=shift;
my $bdb=File::Spec->rel2abs(shift);
my $op=shift;
return $self->create_write_hash_ref($bdb, $op);
}
lib/BDB/Wrapper.pm view on Meta::CPAN
If you set transaction for storing transaction log, transaction will be used and ($bdb_handler, $transaction_handler) will be returned.
=cut
sub create_write_dbh(){
my $self=shift;
my $bdb=shift;
my $op='';
if($bdb && ref($bdb) eq 'HASH'){
$op=$bdb;
lib/BDB/Wrapper.pm view on Meta::CPAN
If you set reverse_cmp 1, you can use sub {$_[1] cmp $_[0]} for sort_code_ref.
If you set transaction 1, you will use /tmp/bdbwrapper/txn_data for the storage of transaction.
=cut
sub create_read_dbh(){
my $self=shift;
my $bdb=shift;
my $op='';
my $transaction=undef;
if($bdb && ref($bdb) eq 'HASH'){
lib/BDB/Wrapper.pm view on Meta::CPAN
If you set reverse_cmp 1, you can use sub {$_[1] cmp $_[0]} for sort_code_ref.
=cut
sub create_write_hash_ref(){
my $self=shift;
my $bdb=shift;
my $op='';
if($bdb && ref($bdb) eq 'HASH'){
$op=$bdb;
lib/BDB/Wrapper.pm view on Meta::CPAN
If you set use_env 1, you can use environment for this method.
=cut
sub create_read_hash_ref(){
my $self=shift;
my $bdb=shift;
my $op='';
if($bdb && ref($bdb) eq 'HASH'){
$op=$bdb;
lib/BDB/Wrapper.pm view on Meta::CPAN
This creates the specified directory recursively.
rmkdir($dir);
=cut
sub rmkdir(){
my $self=shift;
my $path=shift;
my $force=shift;
if($path){
$path=~ s!^\s+|\s+$!!gs;
lib/BDB/Wrapper.pm view on Meta::CPAN
get_bdb_home($bdb);
=cut
sub clear_bdb_home(){
my $self = shift;
my $op = shift;
my $bdb = $op->{'bdb'};
my $home_dir=$self->get_bdb_home({'bdb'=>$bdb});
# Prevent OS command injection
}
sub get_bdb_home(){
my $self=shift;
my $op=shift;
my $bdb='';
my $transaction=undef;
my $lock_root=$self->{'lock_root'};
lib/BDB/Wrapper.pm view on Meta::CPAN
clear_bdb_home($bdb);
=cut
sub clear_bdb_home(){
my $self=shift;
my $op=shift;
my $bdb='';
my $transaction=undef;
my $lock_root=$self->{'lock_root'};
lib/BDB/Wrapper.pm view on Meta::CPAN
record_error($error_msg)
=cut
sub record_error(){
my $self=shift;
my $op=shift || return;
my $msg='';
my $error_log_file='';
view release on metacpan or search on metacpan
bin/bgpmon_analytics_db_import view on Meta::CPAN
log_info("Total updates processed: $total_msgs");
} #End of injection
} #End of while(1)
} #End of subroutine
sub inject_updates(){
#Now inject the updates into the database and apply them to the appropriate tables
my $pwd = `pwd`;
chomp $pwd;
my $db_name = parameter_value('database-name');
my $db_login = parameter_value('database-username');
view release on metacpan or search on metacpan
lib/BGPmon/Filter.pm view on Meta::CPAN
my $prefix_rgx = "\\d+\\.\\d+\\.\\d+\\.\\d+\/\\d+";
my $ip_rgx = "\\d+\\.\\d+\\.\\d+\\.\\d+";
sub ipv4_chkip($) {
#checking to see if it's a prefix or an IPv4 address
my ($ip) = $_[0] =~ /($prefix_rgx)/o;
#print "Is a prefix\n" if $ip;
view release on metacpan or search on metacpan
lib/BGPmon/Filter.pm view on Meta::CPAN
my $prefix_rgx = "\\d+\\.\\d+\\.\\d+\\.\\d+\/\\d+";
my $ip_rgx = "\\d+\\.\\d+\\.\\d+\\.\\d+";
sub ipv4_chkip($) {
#checking to see if it's a prefix or an IPv4 address
my ($ip) = $_[0] =~ /($prefix_rgx)/o;
#print "Is a prefix\n" if $ip;
view release on metacpan or search on metacpan
}
return $data;
}
sub bgs_call(&$) {
my ($sub, $callback) = @_;
my $data = _bgs_call($sub, $callback);
return $$data{vpid};
}
sub bgs_back(&) { shift }
sub bgs_wait(;$) {
my ($waited) = @_;
if ($waited and not exists $vpid2data{$waited} and not grep { $$_{vpid} eq $waited } @to_call) {
return;
}
}
}
sub bgs_break(;$) {
my ($vpid) = @_;
if (defined $vpid) {
my $data = $vpid2data{$vpid};
defined $data or return;
if (my $pid = $$data{pid}) {
view release on metacpan or search on metacpan
lib/BIND/Conf_Parser.pm view on Meta::CPAN
sub choke {
shift;
confess "parse error: ", @_
}
sub set_toke($$;$) {
my($self, $token, $data) = @_;
$self->{_token} = $token;
$self->{_data} = $data;
}
sub where($;$) {
my $self = shift;
if (@_) {
$self->{_file} . ":" . $_[0]
} else {
$self->{_file} . ":" . $self->{_line}
}
}
sub read_line($) {
my $self = shift;
$self->{_line}++;
chomp($self->{_curline} = $self->{_fh}->getline);
}
sub check_comment($) {
my $self = shift;
for my $i ($self->{_curline}) {
$i=~m:\G#.*:gc and last;
$i=~m:\G//.*:gc and last;
if ($i=~m:\G/\*:gc) {
lib/BIND/Conf_Parser.pm view on Meta::CPAN
return 0
}
return 1
}
sub lex_string($) {
my $self = shift;
my($s, $line);
$line = $self->{_line};
$s = "";
LOOP: for my $i ($self->{_curline}) {
lib/BIND/Conf_Parser.pm view on Meta::CPAN
}
redo LOOP;
}
}
sub lex_ident($$) {
my $self = shift;
my($i) = @_;
while (! $self->check_comment &&
$self->{_curline} =~ m:\G([^/"*!{};\s]+):gc) {
$i .= $1;
}
$self->set_toke(WORD, $i);
}
sub lex_ipv4($$) {
my $self = shift;
my($i) = @_;
LOOP: for my $j ($self->{_curline}) {
$self->check_comment and last LOOP;
$j=~/\G(\d+)/gc and do { $i .= $1; redo LOOP };
lib/BIND/Conf_Parser.pm view on Meta::CPAN
$i .= ".0";
}
$self->set_toke(IPADDR, $i);
}
sub lex_number($$) {
my $self = shift;
my($n) = @_;
LOOP: for my $i ($self->{_curline}) {
$self->check_comment and last LOOP;
$i=~/\G(\d+)/gc and do { $n .= $1; redo LOOP };
lib/BIND/Conf_Parser.pm view on Meta::CPAN
$i=~m:\G([^/"*!{};\s]+):gc and $self->lex_ident("$n$1"), return;
}
$self->set_toke(NUMBER, $n);
}
sub lex($) {
my $self = shift;
OUTER: while(1) { for my $i ($self->{_curline}) {
INNER: {
$self->check_comment and last INNER;
$i=~/\G\s+/gc and redo;
lib/BIND/Conf_Parser.pm view on Meta::CPAN
$self->read_line || $i ne "" or $self->set_toke(ENDoFILE), last OUTER;
} }
return $self;
}
sub t2d($) {
my $self = shift;
$self->{_token} eq WORD and return qq('$self->{_data}');
$self->{_token} eq STRING and return qq("$self->{_data}");
$self->{_token} eq NUMBER ||
$self->{_token} eq IPADDR and return $self->{_data};
$self->{_token} eq ENDoFILE and return "<end of file>";
return qq('$self->{_token}');
}
sub t2n($;$) {
my($token, $need_article);
my($map) = {
WORD , [ an => "identifier"],
STRING , [ a => "string"],
NUMBER , [ a => "number"],
lib/BIND/Conf_Parser.pm view on Meta::CPAN
} else {
$map->[-1]
}
}
sub expect($$$;$) {
my $self = shift;
my($token, $mess, $nolex) = @_;
$self->lex unless $nolex;
$token = [ $token ] unless ref $token;
foreach (@{ $token }) {
lib/BIND/Conf_Parser.pm view on Meta::CPAN
$self->choke("Unexpected ", t2n($self->{_token}), " (",
$self->t2d, ") $mess at ", $self->where);
}
}
sub open_file($$) {
require IO::File;
my $self = shift;
my($file) = @_;
$self->{_fh} = IO::File->new($file, "r")
or croak "Unable to open $file for reading: $!";
$self->{_file} = $file;
}
sub parse_bool($$) {
my($self, $mess) = @_;
$self->expect([ WORD, STRING, NUMBER ], $mess);
my($value) = {
"yes" => 1,
"no" => 0,
lib/BIND/Conf_Parser.pm view on Meta::CPAN
}->{$self->{_data}};
return $value if defined $value;
$self->choke("Expected a boolean, saw `", $self->{_data}, "' at ",
$self->where);
}
sub parse_addrmatchlist($$;$) {
my($self, $mess, $nolex) = @_;
$self->expect('{', $mess, $nolex);
my(@items, $negated, $data);
while(1) {
$negated = 0;
lib/BIND/Conf_Parser.pm view on Meta::CPAN
} continue {
$self->expect(';', $mess);
}
return \@items
}
sub parse_addrlist($$) {
my($self, $mess) = @_;
$self->expect('{', $mess);
my(@addrs);
while (1) {
$self->expect([ IPADDR, '}' ], $mess);
lib/BIND/Conf_Parser.pm view on Meta::CPAN
return \@addrs;
# return \@addrs if @addrs;
# $self->choke("Expected at least one IP address, saw none at ",
# $self->where);
}
sub parse_size($$) {
my($self, $mess) = @_;
$self->expect([ WORD, STRING ], $mess);
my($data) = $self->{_data};
if ($data =~ /^(\d+)([kmg])$/i) {
return $1 * {
lib/BIND/Conf_Parser.pm view on Meta::CPAN
'g' => 1024*1024*1024,
}->{lc($2)};
}
$self->choke("Expected size string, saw `$data' at ", $self->where);
}
sub parse_forward($$) {
my($self, $mess) = @_;
$self->expect([[qw(only first)]], $mess);
return $self->{_data};
}
sub parse_transfer_format($$) {
my($self, $mess) = @_;
$self->expect([[qw(one-answer many-answers)]], $mess);
return $self->{_data};
}
sub parse_check_names($$) {
my($self, $mess) = @_;
$self->expect([[qw(warn fail ignore)]], $mess);
return $self->{_data};
}
sub parse_pubkey($$) {
my($self, $mess) = @_;
my($flags, $proto, $algo);
$self->expect([ NUMBER, WORD, STRING ], $mess);
$flags = $self->{_data};
if ($self->{_token} ne NUMBER) {
lib/BIND/Conf_Parser.pm view on Meta::CPAN
$algo = $self->{_data};
$self->expect(STRING, $mess);
return [ $flags, $proto, $algo, $self->{_data} ];
}
sub parse_logging_category($) {
my $self = shift;
$self->expect([ WORD, STRING ], "following `category'");
my($name) = $self->{_data};
$self->expect('{', "following `category $name'");
my(@names);
lib/BIND/Conf_Parser.pm view on Meta::CPAN
}
$self->expect(';', "to finish category `$name'");
$self->handle_logging_category($name, \@names);
}
sub parse_logging_channel($) {
my $self = shift;
$self->expect([ WORD, STRING ], "following `channel'");
my($name) = $self->{_data};
$self->expect('{', "following `channel $name'");
my(%options, $temp);
lib/BIND/Conf_Parser.pm view on Meta::CPAN
}
$self->expect(';', "to finish channel `$name'");
$self->handle_logging_channel($name, \%options);
}
sub parse_logging($) {
my $self = shift;
$self->expect('{', "following `logging'");
while (1) {
$self->expect([ [ qw(category channel) ], '}' ],
"reading logging options");
lib/BIND/Conf_Parser.pm view on Meta::CPAN
}
return \@items;
},
);
sub parse_key($) {
my $self = shift;
$self->expect([ WORD, STRING ], "following `key'");
my($key, $algo, $secret);
$key = $self->{_data};
$self->expect('{', "following key name `$key'");
lib/BIND/Conf_Parser.pm view on Meta::CPAN
$self->expect('}', "reading key `$key'");
$self->expect(';', "to finish key `$key'");
$self->handle_key($key, $algo, $secret);
}
sub parse_controls($) {
my $self = shift;
$self->expect('{', "following `controls'");
while(1) {
$self->expect([ [ qw(inet unix) ], ';' ], "reading `controls'");
last if $self->{_token} eq ';';
lib/BIND/Conf_Parser.pm view on Meta::CPAN
}
}
$self->expect('}', "finishing `controls'");
}
sub parse_server($) {
my $self = shift;
$self->expect(IPADDR, "following `server'");
my($addr, %options);
$addr = $self->{_data};
$self->expect('{', "following `server $addr'");
lib/BIND/Conf_Parser.pm view on Meta::CPAN
}
$self->expect(';', "to finish server `$addr'");
$self->handle_server($addr, \%options);
}
sub parse_trusted_keys($) {
my $self = shift;
$self->expect('{', "following `trusted-keys'");
my($domain, $flags, $proto, $algo);
while(1) {
$self->expect([ WORD, '}' ], "while reading key for `trusted-keys'");
lib/BIND/Conf_Parser.pm view on Meta::CPAN
$self->parse_pubkey("while reading key for `trusted-keys'"));
}
$self->expect(';', "to finish trusted-keys");
}
sub parse_zone($) {
my $self = shift;
my($name, $class);
$self->expect([ WORD, STRING ], "following `zone'");
$name = $self->{_data};
$self->expect([ WORD, STRING, '{', ';' ], "following `zone $name'");
lib/BIND/Conf_Parser.pm view on Meta::CPAN
} else {
$self->handle_zone($name, $class, $options{type}, \%options);
}
}
sub parse_options($) {
my $self = shift;
$self->expect('{', "following `options'");
my($type, $option, $arg, $ate_semi, $did_handle_option);
while (1) {
$self->expect([ WORD, '}' ], "reading options");
lib/BIND/Conf_Parser.pm view on Meta::CPAN
unless $did_handle_option;
}
$self->expect(';', "to finish options");
}
sub parse_conf() {
my $self = shift;
$self->{_curline} = '';
$self->{_flags} = { };
while (1) {
$self->expect([ ENDoFILE, WORD ], "at beginning of statement");
view release on metacpan or search on metacpan
inc/Test/More.pm view on Meta::CPAN
return $tb->unlike(@_);
}
#line 476
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
return $tb->cmp_ok(@_);
}
view release on metacpan or search on metacpan
lib/BPM/XPDL.pm view on Meta::CPAN
);
#--------
sub new($)
{ my $class = shift;
$class->SUPER::new(direction => 'RW', @_);
}
sub init($)
{ my ($self, $args) = @_;
$args->{allow_undeclared} = 1
unless exists $args->{allow_undeclared};
$self->SUPER::init($args);
lib/BPM/XPDL.pm view on Meta::CPAN
$self->importDefinitions(\@xsds);
$self;
}
sub from($@)
{ my ($thing, $source, %args) = @_;
my $xml = XML::Compile->dataToXML($source);
my $top = type_of_node $xml;
my ($ns, $topname) = unpack_type $top;
lib/BPM/XPDL.pm view on Meta::CPAN
}
(pack_type($self->namespace, 'Package'), , $data);
}
sub convert10to20($)
{ my ($self, $data) = @_;
trace "Convert xpdl version from 1.0 to 2.0";
# The conversions to be made are described in the XPDL specification
lib/BPM/XPDL.pm view on Meta::CPAN
$data->{PackageHeader}{XPDLVersion} = '2.0';
$data;
}
sub convert20to21($)
{ my ($self, $data) = @_;
trace "Convert xpdl version from 2.0 to 2.1";
# Tool has been removed from the spec. However, it can still be
lib/BPM/XPDL.pm view on Meta::CPAN
}
#----------
sub version() {shift->{version}}
sub namespace() {shift->{namespace}}
#--------
sub create($)
{ my ($self, $data) = @_;
my $doc = XML::LibXML::Document->new('1.0', 'UTF-8');
my $wr = $self->writer('Package')
or panic "cannot find Package type";
view release on metacpan or search on metacpan
lib/BSD/arc4random.pm view on Meta::CPAN
all => [ @EXPORT_OK ],
);
}
use vars qw($RANDOM); # public tied integer variable
sub have_kintf() {} # public constant function, prototyped
my $have_threadlock = 1;
my $arcfour_lock;
eval { require threads::shared; };
if ($@) {
view release on metacpan or search on metacpan
inc/Test/Base.pm view on Meta::CPAN
$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) {
inc/Test/Base.pm view on Meta::CPAN
$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(@_))
inc/Test/Base.pm view on Meta::CPAN
}
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);
inc/Test/Base.pm view on Meta::CPAN
$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 {
inc/Test/Base.pm view on Meta::CPAN
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
inc/Test/Base.pm view on Meta::CPAN
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);
inc/Test/Base.pm view on Meta::CPAN
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}) {
inc/Test/Base.pm view on Meta::CPAN
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}) {
inc/Test/Base.pm view on Meta::CPAN
$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});
inc/Test/Base.pm view on Meta::CPAN
$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);
inc/Test/Base.pm view on Meta::CPAN
$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);
inc/Test/Base.pm view on Meta::CPAN
$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});
inc/Test/Base.pm view on Meta::CPAN
};
}
return $spec;
}
sub _strict_warnings() {
require Filter::Util::Call;
my $done = 0;
Filter::Util::Call::filter_add(
sub {
return 0 if $done;
inc/Test/Base.pm view on Meta::CPAN
$done = 1;
}
);
}
sub tie_output() {
my $handle = shift;
die "No buffer to tie" unless @_;
tie $handle, 'Test::Base::Handle', $_[0];
}
inc/Test/Base.pm view on Meta::CPAN
$ENV{TEST_SHOW_NO_DIFFS} = 1;
}
package Test::Base::Handle;
sub TIEHANDLE() {
my $class = shift;
bless \ $_[0], $class;
}
sub PRINT {
inc/Test/Base.pm view on Meta::CPAN
sub AUTOLOAD {
return;
}
sub block_accessor() {
my $accessor = shift;
no strict 'refs';
return if defined &$accessor;
*$accessor = sub {
my $self = shift;
view release on metacpan or search on metacpan
lib/BSD/getloadavg.pm view on Meta::CPAN
require XSLoader;
XSLoader::load('BSD::getloadavg', $VERSION);
# Preloaded methods go here.
sub getloadavg(){
my $retval = xs_getloadavg();
if ($DEBUG){
eval {
require Devel::Peek;
Devel::Peek::Dump($retval);