view release on metacpan or search on metacpan
lib/Conjury/Core.pm view on Meta::CPAN
current context object. The C<$Top_Context> package variable always contains a
reference to the context at the top of the source file hierarchy.
=cut
sub _new_f() { __PACKAGE__ . '::new' }
BEGIN {
my $proto;
$proto = Conjury::Core::Prototype->new;
lib/Conjury/Core.pm view on Meta::CPAN
=cut
my %journal_name;
sub _new_f() { __PACKAGE__ . '::new' }
BEGIN {
my $proto;
$proto = Conjury::Core::Prototype->new;
lib/Conjury/Core.pm view on Meta::CPAN
modification time of a source file results in a cascading change to the
signature of every spell that references it in its tree of factors.
=cut
sub _new_f() { __PACKAGE__ . '::new' }
BEGIN {
my $proto;
$proto = Conjury::Core::Prototype->new;
lib/Conjury/Core.pm view on Meta::CPAN
=over 4
=cut
sub _cast_f() { __FILE__ . '/cast' }
sub _cast_warning_f() { __PACKAGE__ . '::cast_warning' }
sub _cast_error_f() { __PACKAGE__ . '::cast_error' }
sub _execute_f() { __PACKAGE__ . '::execute' }
sub _name_spell_f() { __PACKAGE__ . '::name_spell' }
sub _fetch_spells_f() { __PACKAGE__ . '::fetch_spells' }
sub _find_stage_f() { __PACKAGE__ . '::find_state' }
sub _deferral_f() { __PACKAGE__ . '::deferral' }
sub _filecopy_f() { __PACKAGE__ . '::filecopy' }
sub _dispell_f() { __PACKAGE__ . '::dispell' }
BEGIN {
my $proto;
$proto = Conjury::Core::Prototype->new;
view release on metacpan or search on metacpan
lib/Connector/Multi.pm view on Meta::CPAN
# Push path on top of the argument array
unshift @args, [ @prefix, @suffix ];
return $conn->$call( @args );
}
sub get_wrapper() {
my $self = shift;
my $location = shift;
return Connector::Wrapper->new({ BASECONNECTOR => $self, TARGET => $location });
}
# getWrapper() is deprecated - use get_wrapper() instead
sub getWrapper() {
my $self = shift;
warn "using deprecated call to getWrapper - use get_wrapper instead";
$self->get_wrapper(@_);
}
view release on metacpan or search on metacpan
t/02-non-numeric.t view on Meta::CPAN
use warnings;
use Test::More tests => 22;
use Const::Dual ();
sub not_a_number($) {
my $value = shift;
my $warn = "";
local $SIG{__WARN__} = sub { $warn .= $_[0] };
$value = int $value;
return $value == 0 && $warn =~ /Argument "[^"]+" isn't numeric in int/;
view release on metacpan or search on metacpan
lib/Const/Fast.pm view on Meta::CPAN
use Scalar::Util qw/reftype blessed/;
use Carp qw/croak/;
use Sub::Exporter::Progressive 0.001007 -setup => { exports => [qw/const/], groups => { default => [qw/const/] } };
sub _dclone($) {
require Storable;
no warnings 'redefine';
*_dclone = \&Storable::dclone;
goto &Storable::dclone;
}
lib/Const/Fast.pm view on Meta::CPAN
Internals::SvREADONLY($_[0], 1);
return;
}
## no critic (ProhibitSubroutinePrototypes, ManyArgs)
sub const(\[$@%]@) {
my (undef, @args) = @_;
croak 'Invalid first argument, need an reference' if not defined reftype($_[0]);
croak 'Attempt to reassign a readonly variable' if &Internals::SvREADONLY($_[0]);
if (reftype $_[0] eq 'SCALAR' or reftype $_[0] eq 'REF') {
croak 'No value for readonly variable' if @args == 0;
view release on metacpan or search on metacpan
lib/Constant/Generate.pm view on Meta::CPAN
} else {
die "Unrecognized type '$utype'";
}
}
sub _getopt(\%$) {
my ($h,$opt) = @_;
foreach ($opt,"-$opt") { return delete $h->{$_} if exists $h->{$_} }
}
sub import {
view release on metacpan or search on metacpan
lib/Context/Preserve.pm view on Meta::CPAN
use base 'Exporter';
our @EXPORT = qw(preserve_context);
our $VERSION = '0.03';
sub preserve_context(&@) {
my $orig = shift;
my %args = @_;
my $replace = $args{replace};
my $after = $args{after};
view release on metacpan or search on metacpan
lib/Contextual/Return.pm view on Meta::CPAN
}
# Let handlers access the result object they're inside...
sub RETOBJ() {
our $__RETOBJ__;
return $__RETOBJ__;
}
use Scalar::Util qw( refaddr );
# Override return value in a C::R handler...
sub RESULT(;&) {
my ($block) = @_;
# Determine call context and arg list...
my $context;
my $args = do { package DB; $context=(CORE::caller 1)[5]; my $args = \@DB::args; ()=CORE::caller(1); $args };
lib/Contextual/Return.pm view on Meta::CPAN
;
return;
}
sub RVALUE(&;@) :lvalue;
sub LVALUE(&;@) :lvalue;
sub NVALUE(&;@) :lvalue;
my %opposite_of = (
'RVALUE' => 'LVALUE or NVALUE',
'LVALUE' => 'RVALUE or NVALUE',
'NVALUE' => 'LVALUE or RVALUE',
view release on metacpan or search on metacpan
Continuus.pm view on Meta::CPAN
The new method creates a new Continuus object.
=cut
sub new() {
my $self = {};
$self->{DEBUG} = 0;
bless($self);
Continuus.pm view on Meta::CPAN
Example:
$ccm->start(database => "/proj/Continuus0/rig/", host => "stoccm01");
=cut
sub start() {
my $self = shift;
my %args = @_;
my ($command);
$command = "ccm start -m -q -nogui $args{'database'} $args{'host'} $args{'iniFile'} 2>&1";
Continuus.pm view on Meta::CPAN
Example:
$ccm->command('status');
=cut
sub command() {
my $self = shift;
my $command = shift;
my $result;
printDebug($command);
Continuus.pm view on Meta::CPAN
Parameters:
None.
=cut
sub stop() {
my $StopMessage = `ccm stop 2>&1`;
if ($? ne 0) {
# Continuus stop failed
warn "Continuus stop failed.\n$StopMessage\n";
return 0;
Continuus.pm view on Meta::CPAN
Example:
$ccm->query(query => "status='released'", flags => "-u", format => "%objectname");
=cut
sub query() {
my $self = shift;
my %args = @_;
my ($output,$command,@list);
Continuus.pm view on Meta::CPAN
Example:
$ccm->checkOut(file => "main.c", version => "1.1");
=cut
sub checkOut() {
my $self = shift;
my %args = @_;
my ($result, $command);
if (defined $args{'version'}) {
Continuus.pm view on Meta::CPAN
Example:
$ccm->checkIn(file => "main.c", comment => "Created");
=cut
sub checkIn() {
my $self = shift;
my %args = @_;
my ($result, $command);
if (defined $args{'comment'}) {
Continuus.pm view on Meta::CPAN
Example:
$ccm->checkOut(file => "main.c", version => "1.1");
=cut
sub reconfigure() {
my $self = shift;
my %args = @_;
my ($result, $command);
$command = "ccm reconf -p $args{'project'} $args{'parameter'}";
Continuus.pm view on Meta::CPAN
return $?;
}
################################################################################
sub printDebug() {
my $self = shift;
my $tString = shift;
if($self->{DEBUG} == 1) {
print "DEBUG: $tString\n";
Continuus.pm view on Meta::CPAN
Sets the debugging information on.
=cut
sub debugOn() {
my $self = shift;
$self->{DEBUG} = 1;
}
Continuus.pm view on Meta::CPAN
Sets the debugging information off.
=cut
sub debugOff() {
my $self = shift;
$self->{DEBUG} = 0;
}
################################################################################
sub untaint($) {
my $ToUntaint = shift();
if ($ToUntaint =~ /(.+)/ms) { $ToUntaint = $1; }
return $ToUntaint;
};
view release on metacpan or search on metacpan
printf "$indent%-16.16s %-6.6s %s\n", $tag, lc $type, $data;
}
}
}
sub ber_dump($;$$) {
_ber_dump $_[0], $_[1] || $DEFAULT_PROFILE, $_[2];
}
=head1 PROFILES
view release on metacpan or search on metacpan
lib/Convert/Base32.pm view on Meta::CPAN
$bits2char{$bin} = $sym;
} while $bin =~ s/(.+)0\z/$1/s;
}
sub encode_base32_pre58($) {
length($_[0]) == bytes::length($_[0])
or Carp::croak('Data contains non-bytes');
my $str = unpack('B*', $_[0]);
lib/Convert/Base32.pm view on Meta::CPAN
return $str;
}
}
sub encode_base32_perl58($) {
$_[0] =~ tr/\x00-\xFF//c
and Carp::croak('Data contains non-bytes');
my $str = unpack('B*', $_[0]);
lib/Convert/Base32.pm view on Meta::CPAN
return $str;
}
}
sub decode_base32_pre58($) {
( length($_[0]) != bytes::length($_[0]) || $_[0] =~ tr/a-zA-Z2-7//c )
and Carp::croak('Data contains non-base32 characters');
my $str;
if (length($_[0]) < 8*1024) {
lib/Convert/Base32.pm view on Meta::CPAN
return pack('B*', $str);
}
sub decode_base32_perl58($) {
$_[0] =~ tr/a-zA-Z2-7//c
and Carp::croak('Data contains non-base32 characters');
my $str;
if (length($_[0]) < 8*1024) {
view release on metacpan or search on metacpan
lib/Convert/BaseN.pm view on Meta::CPAN
use warnings;
use strict;
our $VERSION = sprintf "%d.%02d", q$Revision: 0.1 $ =~ /(\d+)/g;
use Carp;
sub _make_tr($$;$) {
my ( $from, $to, $opt ) = @_;
$opt ||= '';
my $tr = eval qq{ sub{ \$_[0] =~ tr#$from#$to#$opt } };
croak $@ if $@;
$tr;
view release on metacpan or search on metacpan
lib/Convert/DUDE.pm view on Meta::CPAN
$prev = $n;
}
return $output;
}
sub to_dude($) {
my $domain = shift;
return __PACKAGE__->prefix . dude_encode($domain);
}
=begin algorithm
view release on metacpan or search on metacpan
bin/eds2xdd view on Meta::CPAN
local $/;
while (<>) {
print eds2xdd_string $_;
}
sub VERSION_MESSAGE() { print "Convert::EDS::XDD v$Convert::EDS::XDD::VERSION\n"; }
sub HELP_MESSAGE() {
print <<"EOT"
Usage: $0 [eds_file]
echo 'eds_content' | $0
Opens files passed as arguments and writes them to stdout as XDD.
view release on metacpan or search on metacpan
t/Test/More.pm view on Meta::CPAN
cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
=cut
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
$tb->cmp_ok(@_);
}
view release on metacpan or search on metacpan
lib/Convert/RACE.pm view on Meta::CPAN
my $class = shift;
$_prefix_tag = $_[0] if (@_);
return $_prefix_tag;
}
sub to_race($) {
my $str = shift;
# 2.2.1 Check the input string for disallowed names
unless (_include_disallowed_names($str)) {
Carp::croak('String includes no internationalized characters');
lib/Convert/RACE.pm view on Meta::CPAN
# 2.2.5 Prepend "bq--" to the encoded string and finish
return $_prefix_tag . $encoded;
}
sub from_race($) {
my $str = lc(shift);
# 2.3.1 Strip the "bq--"
$str =~ s/^$_prefix_tag// or Carp::croak("String not begin with $_prefix_tag");
lib/Convert/RACE.pm view on Meta::CPAN
return $decompressed;
}
sub _compress($) {
my $str = shift;
my @unique_upper_octet = _make_uniq_upper_octet($str);
if (@unique_upper_octet > 2 ||
(@unique_upper_octet == 2 &&
lib/Convert/RACE.pm view on Meta::CPAN
return $res;
}
sub _decompress($) {
my $str = shift;
# 1)
my ($u1, $rest) = (substr($str,0,1), substr($str,1));
if (length($str) == 1) {
lib/Convert/RACE.pm view on Meta::CPAN
next;
} continue { $pos++; }
}
sub _make_uniq_upper_octet($) {
my $str = shift;
my %seen;
while ($str =~ m/(.)./gs) {
$seen{$1}++;
}
return keys %seen;
}
sub _include_disallowed_names($) {
# RFC 1035: letter, digit, hyphen
return $_[0] !~ /^(?:\x00[\x30-\x39\x41-\x5a\x61-\x7a\x2d])*$/;
}
view release on metacpan or search on metacpan
# dummy function for compatiiblity with pre-1.7 versions
sub Initialize { }
# action code -> string mapping
sub straction($) {
return 'copying' if $_[0] == &ACT_COPYING;
return 'decoding' if $_[0] == &ACT_DECODING;
return 'encoding' if $_[0] == &ACT_ENCODING;
return 'idle' if $_[0] == &ACT_IDLE;
return 'scanning' if $_[0] == &ACT_SCANNING;
'unknown';
}
# encoding type -> string mapping
sub strencoding($) {
return 'uuencode' if $_[0] == &UU_ENCODED;
return 'base64' if $_[0] == &B64_ENCODED;
return 'yenc' if $_[0] == &YENC_ENCODED;
return 'binhex' if $_[0] == &BH_ENCODED;
return 'plaintext' if $_[0] == &PT_ENCODED;
return 'quoted-printable' if $_[0] == &QP_ENCODED;
return 'xxencode' if $_[0] == &XX_ENCODED;
'unknown';
}
sub strmsglevel($) {
return 'message' if $_[0] == &MSG_MESSAGE;
return 'note' if $_[0] == &MSG_NOTE;
return 'warning' if $_[0] == &MSG_WARNING;
return 'error' if $_[0] == &MSG_ERROR;
return 'panic' if $_[0] == &MSG_PANIC;
view release on metacpan or search on metacpan
}
our @localized;
sub localize($) {
shift if $_[0] eq __PACKAGE__;
push @localized, \$_[0];
Coro::LocalScalar::XS::_init($_[0]);
}
view release on metacpan or search on metacpan
Creates a new local port, and returns its ID. A new thread is created and
attached to the port (see C<rcv_async>, below, for details).
=cut
sub rcv_async($$);
sub port_async(;&) {
my $id = "$UNIQ." . $ID++;
my $port = "$NODE#$id";
@_
? rcv_async $port, shift
It is not allowed to call C<rcv_async> more than once on a given port.
=cut
sub rcv_async($$) {
my ($port, $threadcb) = @_;
my (@queue, $coro);
AnyEvent::MP::rcv $port, sub {
my @msg = get "now", 0
or die "expected now emssage to be there, but it wasn't";
=cut
sub get($;$) {
my ($tag, $timeout) = @_;
my $queue = $Coro::current->{_coro_mp_queue}
or Carp::croak "Coro::MP::get called from thread not attached to any port";
=cut
sub _true { 1 }
sub get_cond(;&$) {
my ($cond, $timeout) = @_;
my $queue = $Coro::current->{_coro_mp_queue}
or Carp::croak "Coro::MP::get_cond called from thread not attached to any port";
};
};
=cut
sub peval_async($$) {
_new_coro $_[0], $_[1]
}
=item @reply = syncal $port, @msg, $callback[, $timeout]
my $reversed = syncal 1, $reverse, reverse => "Rotator";
=cut
sub syncal($@) {
my ($timeout, @msg) = @_;
cal @msg, Coro::rouse_cb, $timeout;
Coro::rouse_wait
}
view release on metacpan or search on metacpan
lib/Coro/PrioChannel.pm view on Meta::CPAN
use Coro::Semaphore ();
use List::Util qw(first sum);
use AnyEvent ();
sub SGET() { 0 }
sub SPUT() { 1 }
sub REPRIO() { 2 }
sub NEXTCHECK() { 3 }
sub DATA() { 4 }
sub MAX() { PRIO_MAX - PRIO_MIN + DATA + 1 }
sub new {
# we cheat, just like Coro::Channel.
bless [
view release on metacpan or search on metacpan
value stored in it and use it as any other Coro object, but you must
not otherwise modify the variable itself.
=cut
sub current() { $current } # [DEPRECATED]
=item $Coro::idle
This variable is mainly useful to integrate Coro into event loops. It is
usually better to rely on L<Coro::AnyEvent> or L<Coro::EV>, as this is
schedule; # sleep well
}
};
$unblock_scheduler->{desc} = "[unblock_sub scheduler]";
sub unblock_sub(&) {
my $cb = shift;
sub {
unshift @unblock_queue, [$cb, @_];
$unblock_scheduler->ready;
view release on metacpan or search on metacpan
lib/Couch/DB.pm view on Meta::CPAN
use constant
{ DEFAULT_SERVER => 'http://127.0.0.1:5984',
};
sub new(%)
{ my ($class, %args) = @_;
$class ne __PACKAGE__
or panic "You have to instantiate extensions of this class";
(bless {}, $class)->init(\%args);
}
sub init($)
{ my ($self, $args) = @_;
my $v = delete $args->{api} or panic "Parameter 'api' is required";
$self->{CD_api} = blessed $v && $v->isa('version') ? $v : version->parse($v);
$self->{CD_clients} = [];
lib/Couch/DB.pm view on Meta::CPAN
$self;
}
#-------------
sub api() { $_[0]->{CD_api} }
#-------------
sub createClient(%)
{ my ($self, %args) = @_;
my $client = Couch::DB::Client->new(couch => $self, %{$self->{CD_auth}}, %args);
$client ? $self->addClient($client) : undef;
}
sub db($%)
{ my ($self, $name, %args) = @_;
Couch::DB::Database->new(name => $name, couch => $self, %args);
}
sub node($)
{ my ($self, $name) = @_;
$self->{CD_nodes}{$name} ||= Couch::DB::Node->new(name => $name, couch => $self);
}
sub cluster() { $_[0]->{CD_cluster} ||= Couch::DB::Cluster->new(couch => $_[0]) }
#-------------
#XXX the API-doc might be mistaken, calling the "analyzer" parameter "field".
sub searchAnalyze(%)
{ my ($self, %args) = @_;
my %send = (
analyzer => delete $args{analyzer} // panic "No analyzer specified.",
text => delete $args{text} // panic "No text to inspect specified.",
lib/Couch/DB.pm view on Meta::CPAN
$self->_resultsConfig(\%args),
);
}
sub requestUUIDs($%)
{ my ($self, $count, %args) = @_;
$self->call(GET => '/_uuids',
introduced => '2.0.0',
query => { count => $count },
$self->_resultsConfig(\%args),
);
}
sub freshUUIDs($%)
{ my ($self, $count, %args) = @_;
my $stock = $self->{CDC_uuids} || [];
my $bulk = delete $args{bulk} || 50;
while($count > @$stock)
lib/Couch/DB.pm view on Meta::CPAN
splice @$stock, 0, $count;
}
#-------------
sub addClient($)
{ my ($self, $client) = @_;
$client or return $self;
$client->isa('Couch::DB::Client') or panic;
push @{$self->{CD_clients}}, $client;
$self;
}
sub clients(%)
{ my ($self, %args) = @_;
my $clients = $self->{CD_clients};
my $role = delete $args{role};
$role ? grep $_->canRole($role), @$clients : @$clients;
}
sub client($)
{ my ($self, $name) = @_;
$name = "$name" if blessed $name;
first { $_->name eq $name } $self->clients; # never many: no HASH needed
}
sub call($$%)
{ my ($self, $method, $path, %args) = @_;
$args{method} = $method;
$args{path} = $path;
$args{query} ||= my $query = {};
lib/Couch/DB.pm view on Meta::CPAN
}
sub _callClient { panic "must be extended" }
# Described in the DETAILS below, non-paging commands
sub _resultsConfig($%)
{ my ($self, $args, @more) = @_;
my %config;
exists $args->{"_$_"} && ($config{$_} = delete $args->{"_$_"})
for qw/delay client clients headers/;
lib/Couch/DB.pm view on Meta::CPAN
keys %$args and warn "Unused call parameters: ", join ', ', sort keys %$args;
%config;
}
# Described in the DETAILS below, paging commands
sub _resultsPaging($%)
{ my ($self, $args, @more) = @_;
my %state = (harvested => []);
my $succ; # successor
if(my $succeeds = delete $args->{_succeed})
lib/Couch/DB.pm view on Meta::CPAN
( $self->_resultsConfig($args, @more, on_final => $harvest),
paging => \%state,
);
}
sub _pageRequest($$$$)
{ my ($self, $paging, $method, $query, $send) = @_;
my $params = $method eq 'GET' ? $query : $send;
my $progress = @{$paging->{harvested}}; # within the page
my $start = $paging->{start};
lib/Couch/DB.pm view on Meta::CPAN
mailtime => sub { DateTime::Format::Mail->parse_datetime($_[2]) }, # smart choice by CouchDB?
version => sub { version->parse($_[2]) },
node => sub { $_[0]->node($_[2]) },
);
sub _toPerlHandler($)
{ my ($self, $type) = @_;
$self->{CD_toperl}{$type} || $default_toperl{$type};
}
sub toPerl($$@)
{ my ($self, $data, $type) = (shift, shift, shift);
my $conv = $self->_toPerlHandler($type) or return $self;
exists $data->{$_} && ($data->{$_} = $conv->($self, $_, $data->{$_}))
for @_;
lib/Couch/DB.pm view on Meta::CPAN
# file. In that case, the JSON::XS will write "6". But the server-side
# JSON is type sensitive and may crash.
int => sub { defined $_[2] ? int($_[2]) : undef },
);
sub _toJsonHandler($)
{ my ($self, $type) = @_;
$self->{CD_tojson}{$type} || $default_tojson{$type};
}
sub toJSON($@)
{ my ($self, $data, $type) = (shift, shift, shift);
my $conv = $self->_toJsonHandler($type) or return $self;
exists $data->{$_} && ($data->{$_} = $conv->($self, $_, $data->{$_}))
for @_;
lib/Couch/DB.pm view on Meta::CPAN
my %default_toquery = (
bool => sub { $_[2] ? 'true' : 'false' },
json => sub { encode_json $_[2] },
);
sub _toQueryHandler($)
{ my ($self, $type) = @_;
$self->{CD_toquery}{$type} || $default_toquery{$type}
|| $self->{CD_tojson}{$type} || $default_tojson{$type};
}
sub toQuery($@)
{ my ($self, $data, $type) = (shift, shift, shift);
my $conv = $self->_toQueryHandler($type) or return $self;
exists $data->{$_} && ($data->{$_} = $conv->($self, $_, $data->{$_}))
for @_;
$self;
}
sub jsonText($%)
{ my ($self, $json, %args) = @_;
JSON->new->pretty(not $args{compact})->encode($json);
}
my (%surpress_depr, %surpress_intro);
sub check($$$$)
{ $_[1] or return $_[0];
my ($self, $condition, $change, $version, $what) = @_;
# API-doc versions are sometimes without 3rd part.
my $cv = version->parse($version);
lib/Couch/DB.pm view on Meta::CPAN
#### Extension which perform some tasks which are framework object specific.
# Returns the JSON structure which is part of the response by the CouchDB
# server. Usually, this is the bofy of the response. In multipart
# responses, it is the first part.
sub _extractAnswer($) { panic "must be extended" }
# The the decoded named extension from the multipart message
sub _attachment($$) { panic "must be extended" }
# Extract the decoded body of the message
sub _messageContent($) { panic "must be extended" }
1;
#-------------
view release on metacpan or search on metacpan
eg/durability.pl view on Meta::CPAN
use Couchbase::Bucket;
use Time::HiRes qw(time);
my $begin;
sub mark_begin($) {
my $msg = shift;
$begin = time();
print "$msg\n";
}
sub mark_end {
view release on metacpan or search on metacpan
lib/Lingua/EN/Hyphenate.pm view on Meta::CPAN
}
my %user_def_syl = ();
my %user_def_hyph = ();
sub def_syl($)
{
my $word = $_[0];
$word =~ tr/~//d;
$user_def_syl{$word} = [split /\~/, $_[0]];
}
sub def_hyph($)
{
my $word = $_[0];
$word =~ tr/~//d;
$user_def_hyph{$word} = [split /\~/, $_[0]];
}
sub syllables($) # ($word)
{
return ($_[0]) unless $_[0] =~ /[A-Za-z]/;
my $word = $_[0];
$word =~ s/\A([^a-zA-Z]+)//;
my $leader = $1||'';
lib/Lingua/EN/Hyphenate.pm view on Meta::CPAN
return @syls if wantarray;
return join '~', @syls;
}
sub hyphenate($$;$) # ($word, $width; $hyphen)
{
my $word = shift;
my @syls = @{$user_def_hyph{$word}||[]};
@syls = syllables($word) unless @syls;
my ($width, $hyphen) = (@_,'-');
view release on metacpan or search on metacpan
=cut
our @ISA = qw(Exporter);
our @EXPORT = qw(encode_json decode_json to_json from_json);
sub to_json($@) {
if ($] >= 5.008) {
require Carp;
Carp::croak ("Cpanel::JSON::XS::to_json has been renamed to encode_json,".
" either downgrade to pre-2.0 versions of Cpanel::JSON::XS or".
" rename the call");
} else {
_to_json(@_);
}
}
sub from_json($@) {
if ($] >= 5.008) {
require Carp;
Carp::croak ("Cpanel::JSON::XS::from_json has been renamed to decode_json,".
" either downgrade to pre-2.0 versions of Cpanel::JSON::XS or".
" rename the call");
my $const_false = $false;
*true = sub () { $const_true };
*false = sub () { $const_false };
}
sub is_bool($) {
shift if @_ == 2; # as method call
(ref($_[0]) and UNIVERSAL::isa( $_[0], JSON::PP::Boolean::))
or (exists $INC{'Types/Serialiser.pm'} and Types::Serialiser::is_bool($_[0]))
}
view release on metacpan or search on metacpan
lib/CracTools/Config.pm view on Meta::CPAN
my $default_content = "# Default configuration file __VERSION__\n#\n\n";
$cfg->defaultContent($default_content);
sub PrintVersion() {
printf( "Script '%s' from %s v. %s (%s v. %s)\n",
basename($0),
$CracTools::PACKAGE_NAME, $CracTools::VERSION,
$CracTools::PACKAGE_NAME, $CracTools::VERSION);
}
sub LoadConfig(;$) {
my ($config_file) = @_;
if (!defined $config_file) {
$cfg->update();
$config_file = $cfg->getPath();
}
Config::Simple->import_from($config_file, \%config);
return $config_file;
}
sub getConfVar(;$) {
my $var_name = shift;
my $die = shift;
if(defined $config{$var_name}) {
return $config{$var_name};
} else {
view release on metacpan or search on metacpan
lib/CrawlerCommons/RobotRules.pm view on Meta::CPAN
#-----------------------------------------------------------------------------#
# Private Methods
#------------------#
#-----------------------------------------------------------------------------#
sub _get_path() {
my ($self, $url, $with_query) = @_;
try {
my $uri = URI->new( $url );
my $path = $uri->path();
view release on metacpan or search on metacpan
use Test::More;
use Crypt::Bcrypt qw/bcrypt bcrypt_check bcrypt_prehashed bcrypt_check_prehashed bcrypt_needs_rehash/;
use MIME::Base64 'decode_base64';
sub de_base64($) {
my($text) = @_;
$text =~ tr#./A-Za-z0-9#A-Za-z0-9+/#;
return decode_base64($text);
}
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/Crypt/Eksblowfish/Bcrypt.pm view on Meta::CPAN
=back
=cut
sub bcrypt_hash($$) {
my($settings, $password) = @_;
$password .= "\0" if $settings->{key_nul} || $password eq "";
my $cipher = Crypt::Eksblowfish->new($settings->{cost},
$settings->{salt}, substr($password, 0, 72));
my $hash = join("", map {
lib/Crypt/Eksblowfish/Bcrypt.pm view on Meta::CPAN
Encodes the octet string textually using the form of base 64 that is
conventionally used with bcrypt.
=cut
sub en_base64($) {
my($octets) = @_;
my $text = encode_base64($octets, "");
$text =~ tr#A-Za-z0-9+/=#./A-Za-z0-9#d;
return $text;
}
lib/Crypt/Eksblowfish/Bcrypt.pm view on Meta::CPAN
Decodes an octet string that was textually encoded using the form of
base 64 that is conventionally used with bcrypt.
=cut
sub de_base64($) {
my($text) = @_;
croak "bad base64 encoding"
unless $text =~ m#\A(?>(?:[./A-Za-z0-9]{4})*)
(?:|[./A-Za-z0-9]{2}[.CGKOSWaeimquy26]|
[./A-Za-z0-9][.Oeu])\z#x;
lib/Crypt/Eksblowfish/Bcrypt.pm view on Meta::CPAN
be used as a SETTINGS string for input to this function: the hash part
of the string is ignored on input.
=cut
sub bcrypt($$) {
my($password, $settings) = @_;
croak "bad bcrypt settings"
unless $settings =~ m#\A\$2(a?)\$([0-9]{2})\$
([./A-Za-z0-9]{22})#x;
my($key_nul, $cost, $salt_base64) = ($1, $2, $3);
view release on metacpan or search on metacpan
lib/Crypt/GeneratePassword.pm view on Meta::CPAN
my @set = (
[ ["\x00",'a'..'z'], ["\x00",'a'..'z',@caps] ],
[ ["\x00",'a'..'z',@signs], ["\x00",'a'..'z',@caps,@signs] ]
);
sub chars($$;$@) {
my ($minlen, $maxlen, $set, @restrict) = @_;
$set ||= $set[1][1];
my $res;
my $diff = $maxlen-$minlen;
WORD: {
lib/Crypt/GeneratePassword.pm view on Meta::CPAN
=cut
our $total;
sub word($$;$$$$$)
{
my $language = splice(@_,2,1) || '';
$language =~ s/[^a-zA-Z_]//g;
$language ||= $default_language;
eval "require Crypt::GeneratePassword::$language";
lib/Crypt/GeneratePassword.pm view on Meta::CPAN
redo if (restrict($stripped,$language));
return $randword;
}
}
sub word3($$;$$$$$)
{
my $language = splice(@_,2,1) || '';
$language =~ s/[^a-zA-Z_]//g;
$language ||= $default_language;
eval "require Crypt::GeneratePassword::$language";
lib/Crypt/GeneratePassword.pm view on Meta::CPAN
about your chosen parameters if you use large values for
$count.
=cut
sub analyze($@) {
my $count = shift;
$total = 0;
for (1..$count) {
my $word = &word(@_);
}
return $count/$total;
}
sub analyze3($@) {
my $count = shift;
$total = 0;
for (1..$count) {
my $word = &word3(@_);
}
lib/Crypt/GeneratePassword.pm view on Meta::CPAN
language not yet built-in, feel free to contribute it for inclusion
into this package.
=cut
sub generate_language($@) {
my ($wordlist) = @_;
if (@_ > 1) {
$wordlist = \@_;
} elsif (!ref($wordlist)) {
$wordlist = [ split(/\s+/,$wordlist) ];
lib/Crypt/GeneratePassword.pm view on Meta::CPAN
be made global default language. If you give undef as
$language_description, only the default language will be changed.
=cut
sub load_language($$;$) {
my ($desc,$name,$default) = @_;
$languages{$name} = eval $desc if $desc;
$default_language = $name if $default;
}
lib/Crypt/GeneratePassword.pm view on Meta::CPAN
The default implementation uses perl's rand(),
which might not be appropriate for some sites.
=cut
sub random_number($) {
return int(rand()*$_[0]);
}
=head2 restrict
lib/Crypt/GeneratePassword.pm view on Meta::CPAN
their sexual nature. You might want to hook up a regular password
checker here, or a wordlist comparison.
=cut
sub restrict($$) {
return ($_[0] =~ m/f.ck|ass|rsch|tit|cum|ack|asm|orn|eil|otz|oes/i);
}
=head1 SEE ALSO