view release on metacpan or search on metacpan
t/95benchmark-fields.t view on Meta::CPAN
eval { require Types::Standard } or
plan skip_all => "Types::Standard is not available";
}
use Time::HiRes qw( gettimeofday tv_interval );
sub measure(&)
{
my ( $code ) = @_;
my $start = [ gettimeofday ];
$code->();
return tv_interval $start;
view release on metacpan or search on metacpan
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);
view release on metacpan or search on metacpan
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);
view release on metacpan or search on metacpan
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);
view release on metacpan or search on metacpan
t/02_standard_interface.t view on Meta::CPAN
use Data::Dump qw( dump );
sub Couplet() { 'Data::Couplet' }
my $t = 0;
sub do_test(&) {
my $c = shift;
my @caller = caller();
$caller[2]--;
++$t;
eval {
view release on metacpan or search on metacpan
lib/Data/Decycle.pm view on Meta::CPAN
}
}
our $CALLEE;
sub recsub(&) {
my $code = shift;
sub {
local *CALLEE = \$code;
$code->(@_);
}
}
sub _mkfinder(&) {
my $cb = shift;
return recsub {
return unless ref $_[0];
no warnings 'uninitialized';
return $cb->( $_[0] ) if $_[1]->{ refaddr $_[0] }++;
lib/Data/Decycle.pm view on Meta::CPAN
sub has_cyclic_ref($){ _has_cyclic_ref($_[0], {}) }
*_may_leak = _mkfinder { !isweak($_[0]) };
sub may_leak($){ _may_leak($_[0], {}) }
sub _mkwalker(&){
my $cb = shift;
return recsub {
return unless ref $_[0];
no warnings 'uninitialized';
return $cb->( $_[0] ) if $_[1]->{ refaddr $_[0] }++;
view release on metacpan or search on metacpan
lib/Data/Dmap.pm view on Meta::CPAN
}
sub cut { die bless [@_], 'Data::Dmap::Cut' }
# Stub that inserts empty map cache
sub dmap(&@) { _dmap({}, @_) }
=head1 AUTHOR
Michael Zedeler, C<< <michael@zedeler.dk> >>
view release on metacpan or search on metacpan
lib/Data/Downloader/File.pm view on Meta::CPAN
&& -e $self->storage_path
) ? 1 : 0;
}
# Get the element(s) which produce the min value of a subroutine.
sub _minmap(&@) {
my $sub = shift;
return unless @_;
my @min = (shift);
my $min = $sub->($min[0]);
for (@_) {
lib/Data/Downloader/File.pm view on Meta::CPAN
elsif ( $val == $min ) { push @min, $_; }
}
return @min;
}
# Ditto for max
sub _maxmap(&@) {
my $sub = shift;
return _minmap(sub { -$sub->(shift) }, @_);
}
# Choose the disk (if the repository has multiple disks).
view release on metacpan or search on metacpan
t/t_TestCommon.pm view on Meta::CPAN
open($orig_stdERR, ">&", \*STDERR) or die "dup STDERR: $!";
close STDERR;
open(STDERR, ">", \$inmem_stdERR) or die "redir STDERR: $!";
binmode(STDERR); binmode(STDERR, ":utf8");
}
sub silent(&) {
my $wantarray = wantarray;
my $code = shift;
_start_silent();
my @result = do{
if (defined $wantarray) {
t/t_TestCommon.pm view on Meta::CPAN
my ($fn, $lno) = (caller(0))[1,2];
#use Data::Dumper::Interp; say dvis '###insert_loc_in_evalstr $fn $lno';
"# line $lno \"$fn\"\n".$orig
}
sub timed_run(&$@) {
my ($code, $maxcpusecs, @codeargs) = @_;
my $getcpu = eval {do{
require Time::HiRes;
() = (&Time::HiRes::clock());
t/t_TestCommon.pm view on Meta::CPAN
# to the cwd!
$str =~ s/The media is write protected\S*\R//gs;
$str
}
sub my_capture(&) {
my ($out, $err, @results) = &capture($_[0]);
return( clean_capture_output($out), clean_capture_output($err), @results );
}
sub my_capture_merged(&) {
my ($merged, @results) = &capture_merged($_[0]);
return( clean_capture_output($merged), @results );
}
sub my_tee_merged(&) {
my ($merged, @results) = &tee_merged($_[0]);
return( clean_capture_output($merged), @results );
}
1;
view release on metacpan or search on metacpan
lib/Data/Generator/FromDDL/RecordSet.pm view on Meta::CPAN
my ($chunk) = @_;
my $joined_chunk = uncompress($chunk);
return split ',', $joined_chunk;
}
sub iterate_through_chunks(&) {
my ($self, $code) = @_;
my $columns = $self->columns;
my $num_of_chunks = ceil($self->n / RECORDS_PER_CHUNK);
my $table = $self->table;
view release on metacpan or search on metacpan
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);
view release on metacpan or search on metacpan
lib/Data/Monad/CondVar.pm view on Meta::CPAN
sub _assert_cv($) {
$_[0]->ready and die "[BUG]It already has been ready";
$_[0];
}
sub as_cv(&) {
my $code = shift;
$code->(my $cv = AE::cv);
$cv;
}
sub cv_unit { AnyEvent::CondVar->unit(@_) }
sub cv_zero { AnyEvent::CondVar->zero(@_) }
sub cv_fail { AnyEvent::CondVar->fail(@_) }
sub cv_flat_map_multi(&@) { AnyEvent::CondVar->flat_map_multi(@_) }
sub cv_map_multi(&@) { AnyEvent::CondVar->map_multi(@_) }
sub cv_sequence { AnyEvent::CondVar->sequence(@_) }
sub call_cc(&) {
my $f = shift;
my $ret_cv = AE::cv;
my $skip = sub {
my @v = @_;
view release on metacpan or search on metacpan
lib/Data/Monad/Base/Sugar.pm view on Meta::CPAN
our @EXPORT = qw/pick satisfy yield let/;
our $_PICK = our $_SATISFY =
our $_YIELD = our $_LET = sub { die "called outside for()." };
sub pick($;$) { $_PICK->(@_) }
sub satisfy(&) { $_SATISFY->(@_) }
sub yield(&) { $_YIELD->(@_) }
sub let($$) { $_LET->(@_) }
sub _capture {
my $ref = pop;
lib/Data/Monad/Base/Sugar.pm view on Meta::CPAN
or die "[BUG]result is not tuple";
_capture @{$result->[$_]} => $self->[$_] for 0 .. $#$self;
}
sub for(&) {
my $code = shift;
my @blocks;
{
local $_PICK = sub {
view release on metacpan or search on metacpan
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);
view release on metacpan or search on metacpan
lib/Data/Petitcom/BMP.pm view on Meta::CPAN
my ($width, $height) = @_;
return unless ($width && $height);
for ( @{ SPRITE_SIZE->{$width} } ) { return 1 if ( $height == $_ ) }
}
sub _xy(&;%) {
my $code = shift;
my %opts = @_;
my $width = delete $opts{width} || 256;
my $height = delete $opts{height} || 64;
view release on metacpan or search on metacpan
lib/Data/Pipeline/Machine.pm view on Meta::CPAN
#print "current option keys: ", join(", ", keys %current_options), "\n";
return exists( $current_options{$o} );
}
sub with_options(&$) {
my($code, $options) = @_;
local(%current_options);
@current_options{keys %$options} = (values %$options);
view release on metacpan or search on metacpan
lib/Data/Printer/Scoped.pm view on Meta::CPAN
shift->export_to_level(1);
Data::Printer->import::into(1);
}
# we only blanket disable Data::Printer if a scope() call has been made.
sub scope(&) {
my ($code) = @_;
$enabled = 0;
return preserve_context { $enabled = 1; $code->() }
view release on metacpan or search on metacpan
t/000.2-warn.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 1;
use Data::Printer::Common;
sub warnings(&) {
my $code = shift;
my $got;
local $SIG{__WARN__} = sub {
$got = shift;
};
view release on metacpan or search on metacpan
lib/Data/SExpression.pm view on Meta::CPAN
}
return $thing;
}
sub for_all(&@) {$_[0]() or return 0 foreach (@_[1..$#_]); 1;}
sub _fold_alists {
my $self = shift;
my $thing = shift;
view release on metacpan or search on metacpan
#! perl
use strict;
use warnings;
use Test::More tests => 5;
sub throws_ok(&$;$);
use Data::Struct;
throws_ok {
my $s = struct Foo => qw(foo bar);
view release on metacpan or search on metacpan
lib/Data/Table/Text.pm view on Meta::CPAN
my $file = writeFile(fpe(&temporaryFolder, qw(code pl)), $code); # Create code file
copyFileToRemote($file); # Copy code to server
say STDERR xxxr(qq(perl $file 2>&1)); # Execute code on server and return its output
}
sub parseCommandLineArguments(&$;$) # Call the specified B<$sub> after classifying the specified array of [arguments] in B<$args> into positional and keyword parameters. Keywords are always preceded by one ...
{my ($sub, $args, $valid) = @_; # Sub to call, list of arguments to parse, optional list of valid parameters else all parameters will be accepted
my %valid = sub # Valid keywords
{return () unless $valid; # No keywords definitions
return map {lc($_)=>0} @$valid if ref($valid) =~ m(array)is; # Keyword names as an array but with no explanation
lib/Data/Table/Text.pm view on Meta::CPAN
}
}
$sub->([@positionals], {%keywords})
} # parseCommandLineArguments
sub call(&;@) # Call the specified B<$sub> in a separate child process, wait for it to complete, then copy back the named B<@our> variables from the child process to the calling parent...
{my ($sub, @our) = @_; # Sub to call, names of our variable names with preceding sigils to copy back
my ($package) = caller; # Caller's package
my $folder = &temporaryFolder; # Folder for returned data files
my $pid = fork; # Fork
if (!defined($pid)) # Fork failed
lib/Data/Table/Text.pm view on Meta::CPAN
sub fileModTime($) # Get the modified time of a B<$file> as seconds since the epoch.
{my ($file) = @_; # File name
(stat($file))[9] // 0
}
sub fileOutOfDate(&$@) # Calls the specified sub B<$make> for each source file that is missing and then again against the B<$target> file if any of the B<@source> files were missing or the $tar...
{my ($make, $target, @source) = @_; # Make with this sub, target file, source files
my $exists = -e $target; # Existence of target
my @missing = grep {!-e $_} @source; # Missing files that do not exist will need to be remade
push @missing, $target unless $exists and !@missing; # Add the target if there were missing files
if (!@missing) # If there were no missing files that forced a remake, then check for a source file younger than the target that would force a remake of the target
lib/Data/Table/Text.pm view on Meta::CPAN
{return "Second array has an additional line at index: $ab\n$b[$ab]\n";
}
undef
}
sub forEachKeyAndValue(&%) # Iterate over a hash for each key and value.
{my ($body, %hash) = @_; # Body to be executed, hash to be iterated
&$body($_, $hash{$_}) for sort keys %hash;
}
sub validateHash($@) # Confess if the specified hash does not have all of the specified keys.
lib/Data/Table/Text.pm view on Meta::CPAN
#D2 www # Web processing
sub wwwHeader {say STDOUT qq(Content-Type: text/html;charset=UTF-8\n\n)} # Html header.
sub wwwGitHubAuth(&$$$$) # Logon as a L<GitHub> L<OAuth> app per: L<https://github.com/settings/developers>. If no L<OAuth> code is supplied then a web page is printed that allows the user to req...
{my ($saveUserDetails, $clientId, $clientSecret, $code, $state) = @_; # Process user token once obtained from GitHub, Client id, client secret, authorization code, random string
if (!$code) # Show logon page if no code has been supplied
{my $r = rand =~ s(\A0.) ()r;
say STDOUT <<HTML; # Logon page
lib/Data/Table/Text.pm view on Meta::CPAN
@r # Results of each upload
}
#D1 Processes # Start processes, wait for them to terminate and retrieve their results
sub startProcess(&\%$) # Start new processes while the number of child processes recorded in B<%$pids> is less than the specified B<$maximum>. Use L<waitForAllStartedProcessesToFinish|/waitFor...
{my ($sub, $pids, $maximum) = @_; # Sub to start, hash in which to record the process ids, maximum number of processes to run at a time
warn "Deprecated in favor of newProcessStarter";
while(keys(%$pids) >= $maximum) # Wait for enough processes to terminate to bring us below the maximum number of processes allowed.
{my $p = waitpid 0,0;
# $$pids{$p} or confess "Pid $p not defined in ".dump($pids)."\n";
lib/Data/Table/Text.pm view on Meta::CPAN
}
@r # Resulting rectangular array
}
sub callSubInParallel(&) # Call a sub reference in parallel to avoid memory fragmentation and return its results.
{my ($sub) = @_; # Sub reference
my $file = temporaryFile; # Temporary file to receive results
if (my $pid = fork) # Parent: wait for child Xref to finish
lib/Data/Table/Text.pm view on Meta::CPAN
{storeFile($file, [&$sub]); # Execute child and return results
exit;
}
}
sub callSubInOverlappedParallel(&&) # Call the B<$child> sub reference in parallel in a separate child process and ignore its results while calling the B<$parent> sub reference in the parent process and ret...
{my ($child, $parent) = @_; # Sub reference to call in child process, sub reference to call in parent process
if (my $pid = fork) # Parent
{my $r = [&$parent]; # Parent sub
waitpid $pid, 0; # Wait for child
view release on metacpan or search on metacpan
t/CommonStuff.pm view on Meta::CPAN
sub round($) {
sprintf "%i", shift();
}
sub all_ok(&$$) {
my ($sub, $params, $test_name) = @_;
if (ref($params->[0]) eq 'ARRAY') {
my $iterator = Set::CrossProduct->new( $params );
my $tuple = undef;
while ($tuple = $iterator->get()) {
t/CommonStuff.pm view on Meta::CPAN
}
ok ( $ok, $test_name ) or diag( 'Parameter: ' . Dumper($param) );
}
}
sub all_dies_ok(&$$) {
all_throws_ok($_[0], qr/./, $_[1], $_[2]);
}
sub _throws {
my ( $sub, $class ) = @_;
view release on metacpan or search on metacpan
lib/Data/Traverse.pm view on Meta::CPAN
# Preloaded methods go here.
# Use this sub to do the prototype only. The real fun
# happens in real_traverse.
sub traverse(&$) {
my ( $callback, $ref ) = @_;
my $type = reftype $ref or
croak "Second argument to traverse must be a reference";
real_traverse( $callback, $ref, $type, caller );
view release on metacpan or search on metacpan
t/lib/DataLoader/Test.pm view on Meta::CPAN
Returns a 'tuple' of the L<DataLoader> object and the arrayref.
=cut
sub make_test_loader(&@) {
my ($fn, %options) = @_;
my @load_calls;
my $loader = DataLoader->new(sub {
my @keys = @_;
push @load_calls, \@keys;
view release on metacpan or search on metacpan
t/32-dircodec-universal.t view on Meta::CPAN
my $cas= DataStore::CAS::Virtual->new();
sub decode_utf8 { goto &DataStore::CAS::FS::InvalidUTF8::decode_utf8; }
sub dies_ok(&@) {
my ($code, $regex, $description)= @_;
my $err= '';
try { $code->(); } catch { $err= $_ };
like( $err, $regex, $description );
}
view release on metacpan or search on metacpan
t/10-store-virtual.t view on Meta::CPAN
use Try::Tiny;
use Path::Class;
use Data::Dumper;
use File::stat;
sub dies(&$) {
my ($code, $comment)= @_;
try {
&$code;
fail "Failed to die during '$comment'";
}
catch {
ok "died - $comment";
};
}
sub dies_like(&$$) {
my ($code, $pattern, $comment)= @_;
try {
&$code;
fail "Failed to die during '$comment'";
}
view release on metacpan or search on metacpan
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);
view release on metacpan or search on metacpan
BEGIN { $SIG{__WARN__} = sub { die "WARNING: $_[0]" }; }
BEGIN { use_ok "Debug::Show", qw(debug=show); }
sub warning_from(&) {
my @w;
local $SIG{__WARN__} = sub { push @w, $_[0] };
$_[0]->();
return @w == 0 ? "??? no warning\n" : @w == 1 ? $w[0] :
"??? @{[scalar(@w)]} warnings\n";
view release on metacpan or search on metacpan
lib/Decision/Depends.pm view on Meta::CPAN
use Decision::Depends::OO;
our $self = Decision::Depends::OO->new();
## no critic ( ProhibitSubroutinePrototypes )
sub if_dep(&@)
{
my ( $deps, $run ) = @_;
my @args = &$deps;
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
$self->if_dep( \@args, $run );
}
sub action(&) { $_[0] }
sub test_dep
{
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
view release on metacpan or search on metacpan
s/</</g;
$_
}
sub background(&;&) {
my ($bg, $cb) = @_;
my ($fh_r, $fh_w) = AnyEvent::Util::portable_socketpair
or die "unable to create background socketpair: $!";