view release on metacpan or search on metacpan
$DEBUG >= 2 or return;
eval qq{ require Devel::Peek; } and Devel::Peek::Dump $_[0];
return;
}
sub stat(;$){
my $arg = shift || $_;
my $self =
ref \$arg eq 'SCALAR' ? xs_stat($arg) : xs_fstat(fileno($arg), 0);
defined $self or return;
$USE_OUR_ST and $set_our_st->($self);
return wantarray ? @$self : bless $self;
}
sub lstat(;$){
my $arg = shift || $_;
my $self =
ref \$arg eq 'SCALAR' ? xs_lstat($arg) : xs_fstat(fileno($arg), 1);
defined $self or return;
$USE_OUR_ST and $set_our_st->($self);
view release on metacpan or search on metacpan
my $self = { };
bless $self, "BZFlag::Info";
return $self;
}
sub serverlist(%) {
my $self = shift;
my %options;
while (my @option = splice(@_, 0, 2)) {
$options{$option[0]} = $option[1];
return ($response);
}
sub queryserver(%) {
my $self = shift;
my %options;
while (my @option = splice(@_, 0, 2)) {
$options{$option[0]} = $option[1];
view release on metacpan or search on metacpan
examples/upload-file-async.pl view on Meta::CPAN
version => 'v1',
api => 'Backblaze::B2::v1::AnyEvent',
log_message => sub { warn sprintf "[%d] %s\n", @_; },
);
sub await($) {
my $promise = $_[0];
my @res;
if( $promise->is_unfulfilled ) {
require AnyEvent;
my $await = AnyEvent->condvar;
view release on metacpan or search on metacpan
lib/Badger/Utils.pm view on Meta::CPAN
}
keys %$helpers
}
}
sub is_object($$) {
blessed $_[1] && $_[1]->isa($_[0]);
}
sub textlike($) {
! ref $_[0] # check if $[0] is a non-reference
|| blessed $_[0] # or an object with an overloaded
&& overload::Method($_[0], '""'); # '""' stringification operator
}
sub truelike($) {
falselike($_[0]) ? FALSE : TRUE;
}
sub falselike($) {
(! $_[0] || $_[0] =~ /^(0|off|no|none|false)$/i) ? TRUE : FALSE;
}
sub params {
# enable $DEBUG to track down calls to params() that pass an odd number
view release on metacpan or search on metacpan
lib/Banal/Mini/Utils.pm view on Meta::CPAN
wantarray ? ($self, $class, $proto) : $self;
}
#######################################
sub msg(@) { # Message text builder to be used in error output (warn, die, ...)
#######################################
my $o = blessed ($_[0]) ? shift : caller();
state $pfx = eval { $o->_msg_pfx(@_) } // '';
join ('', $pfx, @_, "\n")
}
lib/Banal/Mini/Utils.pm view on Meta::CPAN
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# ARRAY & LIST related functions
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
######################################
sub tidy_arrayify(;@) { local $_; my @res = ( grep { defined $_ } ( uniq( arrayify( @_) ))) }
#######################################
#=begin STOLEN_FROM_List_MoreUtils
# ------------------------------------------------------
# TAU: The two routines, as well as the comment about 'leaks' were stolen from C<List::MoreUtils>
view release on metacpan or search on metacpan
lib/Banal/Util/Mini.pm view on Meta::CPAN
wantarray ? ($self, $class, $proto) : $self;
}
#######################################
sub msg(@) { # Message text builder to be used in error output (warn, die, ...)
#######################################
my $o = blessed ($_[0]) ? shift : caller();
state $pfx = eval { $o->_msg_pfx(@_) } // '';
join ('', $pfx, @_, "\n")
}
lib/Banal/Util/Mini.pm view on Meta::CPAN
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# ARRAY & LIST related functions
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
######################################
sub tidy_arrayify(;@) { local $_; my @res = ( grep { defined $_ } ( uniq( arrayify( @_) ))) }
#######################################
#=begin STOLEN_FROM_List_MoreUtils
# ------------------------------------------------------
# TAU: The two routines, as well as the comment about 'leaks' were stolen from C<List::MoreUtils>
view release on metacpan or search on metacpan
lib/Banal/Utils/String.pm view on Meta::CPAN
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(trim ltrim rtrim);
# Perl trim function to remove whitespace from the start and end of the string
sub trim($)
{
my $string = shift;
$string =~ s/^\s+//;
$string =~ s/\s+$//;
return $string;
}
# Left trim function to remove leading whitespace
sub ltrim($)
{
my $string = shift;
$string =~ s/^\s+//;
return $string;
}
# Right trim function to remove trailing whitespace
sub rtrim($)
{
my $string = shift;
$string =~ s/\s+$//;
return $string;
}
view release on metacpan or search on metacpan
lib/Bank/Holidays.pm view on Meta::CPAN
: DateTime->now;
$param->{holidays} = reserve_holidays();
bless $param, $package;
}
sub reserve_holidays() {
my $te = HTML::TableExtract->new();
my $ua = LWP::UserAgent->new();
$ua->timeout(120);
view release on metacpan or search on metacpan
lib/Bank/RMD.pm view on Meta::CPAN
$param->{taxyear} = $params{taxyear} || '2005'; #unused
bless $param, $package;
}
sub calculate() {
my ( $package, %params ) = @_;
return undef unless
defined $params{ownerAge} ||
defined $params{ownerBirthDay};
view release on metacpan or search on metacpan
lib/Barcode/DataMatrix/Engine.pm view on Meta::CPAN
Detect the encoding type.
=cut
sub DetectEncoding() #C4 (int i, int ai[], int ai1[], String as[]) : int
{
my $self = shift;
warn "[C4] DetectEncoding(@_)\n" if $DEBUG{TRACE};
my $ai = $self->{ai};
my $i = scalar (@$ai);
view release on metacpan or search on metacpan
lib/Baseball/Simulation.pm view on Meta::CPAN
# Description: Rounds a number
#
# Returns: The rounded number
#
##################################################
sub Round($) {
my $Float = $_[0];
$Float += 0.5;
return int($Float);
}
lib/Baseball/Simulation.pm view on Meta::CPAN
# Description: Removes surrounding white space and comments
#
# Returns: A cleaned up line
#
##################################################
sub StripLine($) {
my $LineToBeParsed = $_[0]; # The text to be stripped
chomp $LineToBeParsed; # Get rid of line feed
# Delete leading spaces;
if ( $LineToBeParsed =~ /^\s+/ ) {
lib/Baseball/Simulation.pm view on Meta::CPAN
# HomerChance - The percentage that a single can be hit
# SacChance - The percentage that a sacrifice occurs
# StolenBaseChance - The percentage that a stolen base occurs
#
##################################################
sub CreateBatterArray(@) {
my ($AtBats, $Hits, $Doubles, $Triples, $Homers, $Walks, $Steals) = @_;
my $TotalAtBats = $AtBats + $Walks;
my $Singles = $Hits - $Doubles - $Triples - $Homers;
my $WalkChance = int (($Walks / $TotalAtBats) * 1000);
my $SinglesChance = int (($Singles / $TotalAtBats) * 1000);
lib/Baseball/Simulation.pm view on Meta::CPAN
# Triples
# Homers
# StolenBases
#
##################################################
sub CreateNewLineup($) {
my $File = $_[0];
my @TotalStats = (0,0,0,0,0,0,0);;
my @PlayerStats = (0,0,0,0,0,0,0);
my $Line;
lib/Baseball/Simulation.pm view on Meta::CPAN
# 3 = triple
# 4 = home run
#
##################################################
#ignore double plays and sacrifices for now
sub AtBat(@) {
my $WalkChance = 0;
my $SingleChance = 0;
my $DoubleChance = 0;
my $TripleChance = 0;
my $HomerChance = 0;
lib/Baseball/Simulation.pm view on Meta::CPAN
#
# Returns: Updated values for: $FirstBase, $FirstBaseStealChance, $
# SecondBase, $SecondBaseStealChance, $ThirdBase, $Score
#
##################################################
sub AdvanceRunner($$$$$$$$) {
my ($Result, $PlayerStealChance, $FirstBase, $FirstBaseStealChance, $SecondBase, $SecondBaseStealChance, $ThirdBase, $Score) = @_;
if ($Result == -1) {
if ($FirstBase && $SecondBase && $ThirdBase) {
#Advance all one
lib/Baseball/Simulation.pm view on Meta::CPAN
# Description: Simulates an inning
#
# Returns: Returns the score from that inning
#
##################################################
sub Inning($) {
my $Who = $_[0];
my $Outs = 0;
my $FirstBase = 0;
my $FirstBaseStealChance = 0;
my $SecondBase = 0;
lib/Baseball/Simulation.pm view on Meta::CPAN
# Average defeats per season
# Average runs scored per season
# Average runs allowed per season
#
##################################################
sub Simulate() {
my $TotalVictories = 0;
my $TotalDefeats = 0;
my $SingleOtherScore = 0;
my $TotalScore = 0;
my $TotalOtherScore = 0;
view release on metacpan or search on metacpan
lib/Bash/History/Read.pm view on Meta::CPAN
undef $ts;
}
}
}
sub each_hist(&) {
my $code = shift;
_doit('each_hist', $code);
}
sub parse_bash_history_file {
view release on metacpan or search on metacpan
lib/Bayonne/Libexec.pm view on Meta::CPAN
return $self;
};
# hangup
sub hangup($) {
my($self) = @_;
my($tsid) = $self->{'tsession'};
if($tsid) {
print STDOUT "$tsid hangup\n";
$self->{'tsession'} = undef;
}
}
# disconnect (server resumes...)
sub detach($$) {
my($self,$code) = @_;
my($tsid) = $self->{'tsession'};
if($tsid) {
print STDOUT "$tsid exit $code\n";
$self->{'tsession'} = undef;
}
}
sub error($$) {
my($self,$msg) = @_;
my($tsid) = $self->{'tsession'};
if($tsid) {
print STDOUT "$tsid error $msg\n";
$self->{'tsession'} = undef;
}
}
sub post($$$) {
my($self, $id, $value) = @_;
my $sid = $self->{head}{'SESSION'};
print STDOUT "$sid POST $id $value\n";
}
sub pathname($$) {
my($self,$file) = @_;
my $prefix = $self->{head}{'PREFIX'};
my $var = $ENV{'SERVER_PREFIX'};
my $ram = $ENV{'SERVER_TMPFS'};
my $tmp = $ENV{'SERVER_TMP'};
lib/Bayonne/Libexec.pm view on Meta::CPAN
return "$var/$file";
}
# check file validity for write/modify
sub filename($$) {
my($self,$file) = @_;
my $prefix = $self->{head}{'PREFIX'};
if(!$file) {
return undef;
lib/Bayonne/Libexec.pm view on Meta::CPAN
return "$file";
}
# move files
sub move($$$) {
my ($self,$file1,$file2) = @_;
$file1 = $self->pathname($file1);
$file2 = $self->pathname($file2);
if(!$file1 || !$file2) {
$self->{'result'} = 254;
lib/Bayonne/Libexec.pm view on Meta::CPAN
return 0;
}
# erase file
sub erase($$) {
my ($self,$file) = @_;
$file = $self->pathname($file);
if(!$file) {
$self->{'result'} = 254;
return 254;
lib/Bayonne/Libexec.pm view on Meta::CPAN
my $voice = shift;
$self->{'voice'} = $voice;
}
sub level($$) {
my($self, $level) = @_;
$self->{'level'} = $level;
}
# process input line
sub input($$$) {
my ($self, $count, $timeout) = @_;
if(!$count) {
$count = 1;
}
lib/Bayonne/Libexec.pm view on Meta::CPAN
return $self->{'digits'};
}
# clear pending input
sub clear($) {
my($self) = @_;
return $self->command("FLUSH");
}
# wait for a key event
sub wait($$) {
my ($self, $timeout) = @_;
if(!$timeout) {
$timeout = 0;
}
lib/Bayonne/Libexec.pm view on Meta::CPAN
return 0;
}
# process single key input
sub inkey($$) {
my ($self, $timeout) = @_;
if(!$timeout) {
$timeout = 0;
}
lib/Bayonne/Libexec.pm view on Meta::CPAN
return substr($self->{'digits'}, 0, 1);
}
# send results back to server.
sub result($$) {
my($self, $buf) = @_;
$buf =~ s/\%/\%\%/g;
$buf =~ s/(.)/ord $1 < 32 ?
sprintf "%%%s", chr(ord($1) + 64) : sprintf "%s",$1/eg;
return $self->command("result $buf");
}
# transfer extension
sub transfer($$) {
my($self, $dest) = @_;
return $self->command("xfer $dest");
}
# get symbol value
sub get($$) {
my($self, $buf) = @_;
$self->command("get $buf");
return $self->{'query'};
}
# set symbol value
sub set($$$) {
my($self, $id, $value) = @_;
return $self->command("set $id $value");
}
sub add($$$) {
my($self, $id, $value) = @_;
return $self->command("add $id $value");
}
# size a symbol
sub size($$$) {
my($self, $id, $buf) = @_;
my($size) = $buf - 0;
return $self->command("new $id $size");
}
# build prompt
sub speak($$) {
my($self, $buf) = @_;
my($voice) = $self->{'voice'};
if(!$voice) {
$voice = "prompt";
lib/Bayonne/Libexec.pm view on Meta::CPAN
return $self->command("$voice $buf");
}
# issue a libexec command and parse the transaction results.
sub command($$) {
my($self,$buf) = @_;
my($hid) = 0;
my($result) = 255; # no result value
my($tsession) = $self->{'tsession'};
my($exitcode) = $self->{'exitcode'};
lib/Bayonne/Libexec.pm view on Meta::CPAN
return $result;
}
# generic print function, works whether in TGI or direct execute mode
sub print($$) {
my($self,$buf) = @_;
$buf =~ s/\%/\%\%/g;
$buf =~ s/(.)/ord $1 < 32 ?
sprintf "%%%s", chr(ord($1) + 64) : sprintf "%s",$1/eg;
if($self->{'tsession'}) {
view release on metacpan or search on metacpan
lib/Bayonne/Server.pm view on Meta::CPAN
};
$self->{_session} = LWP::UserAgent->new(env_proxy => 1, timeout => 30);
return bless $self, $class;
};
sub xmlreply($$) {
my ($self, $query) = @_;
my $host = $self->{hostid};
my $user = $self->{userid};
my $secret = $self->{secret};
my $session = $self->{_session};
lib/Bayonne/Server.pm view on Meta::CPAN
if($response->is_success()) {
$reply = $parser->XMLin($response->{_content});};
return $reply;
};
sub reload($) {
my($self) = @_;
my $reply = $self->xmlreply("reload.xml");
if($reply) {
return $reply->{results}->{result}->{value};};
return "failure";
}
sub uptime($) {
my($self) = @_;
my $reply = $self->xmlreply("uptime.xml");
if($reply) {
return $reply->{results}->{result}->{value};};
return undef;
}
sub status($) {
my($self) = @_;
my $reply = $self->xmlreply("status.xml");
if($reply) {
return $reply->{results}->{result}->{value};};
return undef;
}
sub traffic($) {
my($self) = @_;
my $reply = $self->xmlreply("traffic.xml");
my $result = undef;
if($reply) {
lib/Bayonne/Server.pm view on Meta::CPAN
$reply->{results}->{result}->{outgoingAttempts}->{value};
}
return $result;
}
sub stop($$) {
my($self,$sid) = @_;
my $result = "failure";
$sid = uri_escape($sid);
my $reply = $self->xmlreply("stop.xml?session=$sid");
lib/Bayonne/Server.pm view on Meta::CPAN
return $result;};
return "invalid";
}
sub session($$) {
my($self,$sid) = @_;
my $result = "failure";
$sid = uri_escape($sid);
my $reply = $self->xmlreply("status.xml?session=$sid");
lib/Bayonne/Server.pm view on Meta::CPAN
return $result;};
return "invalid";
}
sub start($$$$$) {
my($self, $target, $script, $caller, $display) = @_;
my $query = "start.xml";
if(length($caller) < 1) {
$caller = "unknown";};
view release on metacpan or search on metacpan
lib/Beam/Make.pm view on Meta::CPAN
has conf => ( is => 'ro', default => sub { YAML::LoadFile( 'Beamfile' ) } );
# Beam::Wire container objects
has _wire => ( is => 'ro', default => sub { {} } );
sub run( $self, @argv ) {
my ( @targets, %vars );
for my $arg ( @argv ) {
if ( $arg =~ /^([^=]+)=([^=]+)$/ ) {
$vars{ $1 } = $2;
lib/Beam/Make.pm view on Meta::CPAN
};
$build->( $_ ) for @targets;
}
# Resolve any references via Beam::Wire container lookups
sub _resolve_ref( $self, $conf ) {
return $conf if !ref $conf || blessed $conf;
if ( ref $conf eq 'HASH' ) {
if ( grep { $_ !~ /^\$/ } keys %$conf ) {
my %resolved;
for my $key ( keys %$conf ) {
view release on metacpan or search on metacpan
lib/Bench.pm view on Meta::CPAN
}
#say "D:fmt=$fmt";
sprintf($fmt, $num) . ($unit // "");
}
sub bench($;$) {
my ($subs0, $opts) = @_;
$opts //= {};
$opts = {n=>$opts} if ref($opts) ne 'HASH';
$opts->{t} //= 1;
$opts->{n} //= 100;
view release on metacpan or search on metacpan
share/P6STD/tools/DumpMatch.pm view on Meta::CPAN
our @ISA = 'Exporter';
our @EXPORT = qw(traverse_match dump_match);
our @EXPORT_OK = qw(process_events);
our $NOCOLOR;
sub RESET() {$NOCOLOR ? '' : Term::ANSIColor::RESET()};
sub RED() {$NOCOLOR ? '' : Term::ANSIColor::RED() };
sub BLUE() {$NOCOLOR ? '' : Term::ANSIColor::BLUE() };
sub YELLOW() {$NOCOLOR ? '' : Term::ANSIColor::YELLOW() };
sub process_events {
my ($orig,$events,$opt) = @_;
my $str = "";
my $at = 0;
view release on metacpan or search on metacpan
lib/Benchmark/Perl/Formance/Plugin/Mandelbrot/withthreads.pm view on Meta::CPAN
my ($w, $h);
my $threads;
# Generate pixel data for a single dot
sub dot($$) { ## no critic
my ($Zr, $Zi, $Tr, $Ti) = (0.0,0.0,0.0,0.0);
my $i = ITER;
my $Cr = 2 * $_[0] / $w - 1.5;
my $Ci = 2 * $_[1] / $h - 1.0;
(
lib/Benchmark/Perl/Formance/Plugin/Mandelbrot/withthreads.pm view on Meta::CPAN
) until ($Tr + $Ti > LIMITSQR || !$i--);
return ($i == -1);
}
# Generate pixel data for range of lines, inclusive
sub lines($$) { ## no critic
map { my $y = $_;
pack 'B*', pack 'C*', map dot($_, $y), 0..$w-1;
} $_[0]..$_[1]
}
view release on metacpan or search on metacpan
lib/Benchmark/Perl/Formance/Plugin/PerlStone2015/mandelbrot.pm view on Meta::CPAN
my ($w, $h);
my $threads;
# Generate pixel data for a single dot
sub dot($$) { ## no critic
my ($Zr, $Zi, $Tr, $Ti) = (0.0,0.0,0.0,0.0);
my $i = ITER;
my $Cr = 2 * $_[0] / $w - 1.5;
my $Ci = 2 * $_[1] / $h - 1.0;
(
lib/Benchmark/Perl/Formance/Plugin/PerlStone2015/mandelbrot.pm view on Meta::CPAN
) until ($Tr + $Ti > LIMITSQR || !$i--);
return ($i == -1);
}
# Generate pixel data for range of lines, inclusive
sub lines($$) { ## no critic
map { my $y = $_;
pack 'B*', pack 'C*', map dot($_, $y), 0..$w-1;
} $_[0]..$_[1]
}
view release on metacpan or search on metacpan
lib/Benchmark/Perl/Formance/Plugin/Shootout/mandelbrot.pm view on Meta::CPAN
my ($w, $h);
my $threads;
# Generate pixel data for a single dot
sub dot($$) { ## no critic
my ($Zr, $Zi, $Tr, $Ti) = (0.0,0.0,0.0,0.0);
my $i = ITER;
my $Cr = 2 * $_[0] / $w - 1.5;
my $Ci = 2 * $_[1] / $h - 1.0;
(
lib/Benchmark/Perl/Formance/Plugin/Shootout/mandelbrot.pm view on Meta::CPAN
) until ($Tr + $Ti > LIMITSQR || !$i--);
return ($i == -1);
}
# Generate pixel data for range of lines, inclusive
sub lines($$) { ## no critic
map { my $y = $_;
pack 'B*', pack 'C*', map dot($_, $y), 0..$w-1;
} $_[0]..$_[1]
}
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
BerkeleyDB.pm view on Meta::CPAN
{ bootstrap BerkeleyDB $VERSION }
# Preloaded methods go here.
sub ParseParameters($@)
{
my ($default, @rest) = @_ ;
my (%got) = %$default ;
my (@Bad) ;
my ($key, $value) ;
view release on metacpan or search on metacpan
lib/Biblio/RFID/Reader/INET.pm view on Meta::CPAN
our $read_char_time = 1;
sub read_char_time { $read_char_time = $_[1] * 1_000 || 1_000_000 };
sub read_const_time {};
sub read(*\$$;$) {
my $self = shift;
my $len = shift || die "no length?";
#warn "XX ",ref($self), " read $len timeout $read_char_time";
my $buffer;
view release on metacpan or search on metacpan
lib/Big5.pm view on Meta::CPAN
# P.331 Inlining Constant Functions
# in Chapter 7: Subroutines
# of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
sub LOCK_SH() {1}
sub LOCK_EX() {2}
sub LOCK_UN() {8}
sub LOCK_NB() {4}
sub unimport {}
sub Big5::escape_script;
# 6.18. Matching Multiple-Byte Characters
view release on metacpan or search on metacpan
lib/Big5HKSCS.pm view on Meta::CPAN
# P.331 Inlining Constant Functions
# in Chapter 7: Subroutines
# of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
sub LOCK_SH() {1}
sub LOCK_EX() {2}
sub LOCK_UN() {8}
sub LOCK_NB() {4}
sub unimport {}
sub Big5HKSCS::escape_script;
# 6.18. Matching Multiple-Byte Characters
view release on metacpan or search on metacpan
scripts/alluniq view on Meta::CPAN
CYAN " ($Script)\n" ;
return 1 ;
}
}
sub tableOutput( ) {
## 2. 度数nã®ç•°ãªã‚‹æ–‡å—列ãŒã€å…·ä½“çš„ã«ã©ã‚“ãªå€¤ã§ã‚ã£ãŸã‹ã€‚
while ( my( $str, $cnt) = each %str2cnt ) {
push @{ $cnt2strs {$cnt} }, $str ;
}
my $msep = $o{2} ? "\n" : "\t" ;
view release on metacpan or search on metacpan
scripts/dirdig view on Meta::CPAN
last if @dirfiles == 0 && ! $o{'.'} && $o{d} > 0 ;
}
}
sub botD( $ ) { # 区切りã§splitã—ã¦ä¸‹ã‹ã‚‰$o{v}個ã®ã¿å–り出ã—ã¦å†é€£çµ
my @t = splitdir shift ;
my @t1 = splice @t , - min( scalar @t , $o{v} ) ;
my $i = $o{d} >= 0 ? '-' : '^' ;
@t = @t ? $i x @t : () ;
return join $T , @t , @t1 ;
view release on metacpan or search on metacpan
scripts/boxmuller view on Meta::CPAN
sub lognormal ( $$ ) {
return exp boxmuller $_[0], $_[1] ;
}
}
sub SecondInfo( ) { # 処ç†ã—ãŸã“ã¨ã«ã¤ã„ã¦ã®äºŒæ¬¡æƒ…å ±ã‚’å‡ºåŠ›
return if $o{1} ;
use FindBin qw [ $Script ] ;
my $cmd = "$Script -m $mu -d $sd" ;
$cmd .= ' -L' if $o{L} ;
print STDERR
view release on metacpan or search on metacpan
scripts/colpairs view on Meta::CPAN
my $len = scalar @_ - 1 ;
# return ( $_[ floor $len * $quot ] + $_[ ceil $len * $quot ] ) / 2 ;
return $_[ floor $len * $quot ] ; # + $_[ ceil $len * $quot ] ) / 2 ;
}
sub qval( $ ) { # qval( 1, 2 ) ; 1番目㯠$pf->[$i][$j]ã¾ã§
my $f = midval $_[0] ;
return grep { $_[0]->{$_} == $f } keys %{ $_[0] } ;
}
view release on metacpan or search on metacpan
lib/Binary/Heap/Array.pm view on Meta::CPAN
eval $s; # Generate and optimise the package
$@ and confess $@;
}
#1 Methods
sub new(*) # Create a new binary heap array. A string of flags enables optimizations to the base version, which uses the minimum amount of memory at all times, to use more memory t...
{my ($flags) = @_; # Optimization flags ipsw in any order surrounding quotes are not necessary
my $f = $flags;
my $name = 'Binary::Heap::Array::';
for(@speedChars) # Generate package name matching requested optimisations
{if ($f =~ m/$_/i)
lib/Binary/Heap/Array.pm view on Meta::CPAN
no overloading;
confess unless speedWidth;
$array->[6] //= (my $v = 0) # Field 7
}
sub at($$) :lvalue # Address the element at a specified index so that it can get set or got
{my ($array, $index) = @_; # Array, index of element
my $n = size($array); # Array size
return undef if $index < -$n or $index >= $n; # Index out of range
return &atUp(@_) if $index >= 0;
&atDown(@_)
lib/Binary/Heap/Array.pm view on Meta::CPAN
my @a = @{subarray($array)};
vec($v, $_, 1) = !!$a[$_] for 0..$#a;
$v
}
sub pop($) # Pop the topmost element from the leading full array and spread the remainder of its contents as sub arrays of the correct size for each preceding empty slot
{my ($array) = @_; # Array from which an element is to be popped
my $N = size($array); # Size of array
return undef unless $N; # Cannot pop from an empty array
if (speedPp) # Fast with pre and post
lib/Binary/Heap/Array.pm view on Meta::CPAN
} # for each subarray
}
confess "This should not happen" # We have already checked that there is at least one element on the array and so an element can be popped so we should not arrive here
} # pop
sub push($$) # Push a new element on to the top of the array by accumulating the leading full sub arrays in the first empty slot or create a new slot if none already available
{my ($array, $element) = @_; # Array, element to push
currentSize($array)++ if speedSize; # Increase cached size of array if possible
if (speedPp and my $p = post($array)) # Allow for post
{if (size($array)) # Quick push
lib/Binary/Heap/Array.pm view on Meta::CPAN
}
}
$array
} # push
sub size($) # Find the number of elements in the binary heap array
{my ($array) = @_; # Array
return currentSize($array) if speedSize; # Use cached size if possible
my $n = 0; # Element count, width of current sub array
my $s = subarray($array); # Array of sub arrays
if ($s and @$s) # Sub array
lib/Binary/Heap/Array.pm view on Meta::CPAN
return $n - $p - $q # Count of elements found with modifications from pre and post
}
$n # Count of elements found
} # size
sub shift($) # Remove and return the current first element of the array
{my ($array) = @_; # Array
my $n = size($array); # Size of array
return undef unless $n; # Use cached size if possible
my $element = at($array, 0); # Check that there is a first element
if (speedPp)
lib/Binary/Heap/Array.pm view on Meta::CPAN
$array->push($_) for @a; # Restore each element one place down
}
$element # Return successfully removed element
} # shift
sub unshift($$) # Insert an element at the start of the array
{my ($array, $element) = @_; # Array, element to be inserted
if (speedPp and pre($array))
{pre($array)--; # Skip over the existing preceding element
currentSize($array)++ if speedSize; # Increase cached size of array if possible
lib/Binary/Heap/Array.pm view on Meta::CPAN
$array->push($_) for $element, @a; # Place new element followed by existing elements
}
$array # Return array so we can chain operations
} # unshift
sub width($) ## Current width of array of sub arrays where the sub arrays hold data in use
{my ($array) = @_; # Array
return currentWidth($array) if speedWidth; # Use cached width if possible
my $w = -1; # Width
my $s = subarray($array); # Array of sub arrays
my $v = inUseVector($array); # Sub arrays in use
for(keys @$s) {$w = $_ if vec($v, $_, 1)}
$w + 1 # Count of elements found
} # width
sub firstEmptySubArray($) ## First unused sub array
{my ($array) = @_; # Array
my $w = width($array); # Width of array of sub arrays
my $v = inUseVector($array); # Sub arrays in use
for(0..$w-1) # Each sub array
{return $_ unless vec($v, $_, 1); # First sub array not in use
}
undef # All sub arrays are in use
} # firstEmptySubArray
sub atUp($$) :lvalue ## Get the element at a specified positive index by going up through the array of sub arrays
{my ($array, $index) = @_; # Array, index of element
$index += pre($array) if speedPp; # Allow for pre and post
my $S = subarray($array); # Sub array list
my $v = inUseVector($array); # Sub arrays in use
for my $i(reverse 0..$#$S) # Start with the widest sub array
lib/Binary/Heap/Array.pm view on Meta::CPAN
$index -= $width; # Reduce the index by the size of this array and move onto the next sub array
}
undef
} # atUp
sub atDown($$) :lvalue ## Get the element at a specified negative index by going down through the array of sub arrays
{my ($array, $index) = @_; # Array, index of element
$index -= post($array) if speedPp; # Allow for pre and post
my $S = subarray($array); # Sub array list
my $v = inUseVector($array); # Sub arrays in use
for my $i(0..$#$S) # Start with the narrowest sub array
lib/Binary/Heap/Array.pm view on Meta::CPAN
use overload # Operator overloading
'@{}'=>\&convertToArray, # So we can process with a for loop
'""' =>\&convertToString, # So we can convert to string
'eq' =>\= # Check whether two arrays are equal
sub convertToArray($) ## Convert to normal perl array so we can use it in a for loop
{my ($array) = @_; # Array to convert
my $w = width($array); # Width of array of sub arrays
my $v = inUseVector($array); # Sub arrays in use
my @a;
for(reverse 0..$w-1) # Each sub array
lib/Binary/Heap/Array.pm view on Meta::CPAN
splice @a, -$q, $q if $q;
}
[@a]
}
sub unpackVector($) # Unpack the in use vector
{my ($array) = @_;
my $v = inUseVector($array);
$v ? unpack("b*", $v) : ''
}
sub convertToString($) ## Convert to string
{my ($array) = @_; # Array to convert
my $e = sub
{my $a = subarray($array);
return '' unless $a and @$a;
lib/Binary/Heap/Array.pm view on Meta::CPAN
}->();
__PACKAGE__."($s$w$p$i$e)" # String representation of array
}
sub equals($$) ## Equals check whether two arrays are equal
{my ($A, $B) = @_; # Arrays to check
my $nA = $A->size;
my $nB = $B->size;
return 0 unless $nA == $nB; # Different sized arrays cannot be equal
for(0..$nA-1) # Check each element
lib/Binary/Heap/Array.pm view on Meta::CPAN
=head1 Methods
=head2 new($flags)
sub new(*) # Create a new binary heap array. A string of flags enables optimizations to the base version, which uses the minimum amount of memory at all times, to use more memory t...
Parameter Description
1 $flags Optimization flags ipsw in any order surrounding quotes are not necessary
=head2 at :lvalue($array, $index)
lib/Binary/Heap/Array.pm view on Meta::CPAN
use Test::More tests=>186237;
sub debug{0} # 0 - no debug, 1 - do debug
our @optimisations; # All combinations of optimizations
my $speed; # The name of the package to test
sub checkWidth($) # Check that all the arrays used in the construction of this binary heap array are a power of two in width
{my ($array) = @_; # Array to check
my $s = $array->subarray; # Sub arrays
return unless $s and @$s; # Empty array is OK
!defined(powerOfTwo(scalar @$s)) # The array must either be empty or a power of two in width
and confess "The width of this array of sub arrays is not a power of two: $array";
lib/Binary/Heap/Array.pm view on Meta::CPAN
!defined(powerOfTwo(scalar @$_)) # The array must either be empty or a power of two in width
and confess "The width of this sub array is not a power of two: $array";
}
} # checkWidth
sub newArray($) # Push: create an array by pushing
{my $number = $_[0]//0;
my $array = Binary::Heap::Array::new($speed); # Request an array with the desired optimizations
$array->push($_-1) for 1..$number;
checkWidth($array);
$array
}
sub ats($) # At
{my ($n) = @_;
my $a = newArray($n);
ok $a->at(0) == 0 if $n;
ok $a->at(1) == 1 if $n > 1;
ok $a->at(-1) == $n-1 if $n;
ok $a->at($_-$n) == $_ for 0..$n-1;
}
sub pops($) # Pop
{my ($n) = @_;
my $a = newArray($n);
for(reverse 0..$n-1)
{ok $a->pop == $_;
ok $a->size == $_;
lib/Binary/Heap/Array.pm view on Meta::CPAN
}
ok !defined($a->pop);
checkWidth($a);
} # pops
sub shifts($) # Shift
{my ($n) = @_;
my $a = newArray($n);
for(0..$n-1)
{ok $a->shift == $_;
ok $a->size == $n - $_ - 1;