view release on metacpan or search on metacpan
lib/CORBA/IDLtree.pm view on Meta::CPAN
# };
# It is needed because the node is not constructed until the end of the
# structure declaration, and members may have trailing comments which
# would overwrite the single post_comment buffer.
sub in_annotation_def() {
return (@typestack && $typestack[$#typestack] == ANNOTATION);
}
sub set_verbose {
if (@_) {
view release on metacpan or search on metacpan
omnithreads/t/problems.t view on Meta::CPAN
my $test :shared = 2;
# Note that we can't use Test::More here, as we would need to call is()
# from within the DESTROY() function at global destruction time, and
# parts of Test::* may have already been freed by then
sub is($$$)
{
my ($got, $want, $desc) = @_;
lock($test);
if ($got ne $want) {
print("# EXPECTED: $want\n");
view release on metacpan or search on metacpan
# ABSTRACT: Expected failures
use CPAN::Changes::Group::Dependencies::Details;
sub is_fail($$) {
my ( $reason, $sub ) = @_;
local $@;
my $failed = 1;
eval {
$sub->();
view release on metacpan or search on metacpan
use Test::More tests => 4;
# ABSTRACT: Things that fail
use CPAN::Changes::Group::Dependencies::Stats;
sub is_fail($$) {
my ( $reason, $code ) = @_;
local $@;
my $failed = 1;
eval {
$code->();
@_ = 'die expected:' . $reason;
goto \&fail;
}
}
sub isnt_fail($$) {
my ( $reason, $code ) = @_;
local $@;
my $failed = 1;
eval {
$code->();
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
};
}
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
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
};
}
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
t/lib/Helper.pm view on Meta::CPAN
#--------------------------------------------------------------------------#
# test config file prep
#--------------------------------------------------------------------------#
sub test_fake_config_plan() { 4 }
sub test_fake_config {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my %overrides = @_;
is( File::HomeDir::my_documents(), MockHomeDir::home_dir(),
t/lib/Helper.pm view on Meta::CPAN
#--------------------------------------------------------------------------#
# Test grade_PL
#--------------------------------------------------------------------------#
sub test_grade_PL_iter_plan() { 5 }
sub test_grade_PL_plan() { test_grade_PL_iter_plan() * 2 }
sub test_grade_PL {
my ($case, $dist) = @_;
local $Test::Builder::Level = $Test::Builder::Level + 1;
local $ENV{PERL_MM_USE_DEFAULT} = 1;
my $short_name = _short_name( $dist );
t/lib/Helper.pm view on Meta::CPAN
#--------------------------------------------------------------------------#
# Test grade_make
#--------------------------------------------------------------------------#
sub test_grade_make_iter_plan() { 6 }
sub test_grade_make_plan() { test_grade_make_iter_plan() * 2 }
sub test_grade_make {
my ($case, $dist) = @_;
local $Test::Builder::Level = $Test::Builder::Level + 1;
local $ENV{PERL_MM_USE_DEFAULT} = 1;
my $short_name = _short_name( $dist );
t/lib/Helper.pm view on Meta::CPAN
#--------------------------------------------------------------------------#
# Test grade_test
#--------------------------------------------------------------------------#
sub test_grade_test_iter_plan() { 7 }
sub test_grade_test_plan() { 2 * test_grade_test_iter_plan() }
sub test_grade_test {
my ($case, $dist) = @_;
local $Test::Builder::Level = $Test::Builder::Level + 1;
local $ENV{PERL_MM_USE_DEFAULT} = 1;
my $short_name = _short_name( $dist );
t/lib/Helper.pm view on Meta::CPAN
http://wiki.cpantesters.org/wiki/CPANAuthorNotes
HERE
);
sub test_report_plan() { 17 };
sub test_report {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my ($case) = @_;
my $label = "$case->{label}:";
view release on metacpan or search on metacpan
lib/CPAN/Site/Index.pm view on Meta::CPAN
my $tar_gz = qr/ \.tar\.gz$ | \.tar\.Z$ | \.tgz$/xi;
my $zip = qr/ \.zip$ /xi;
my $cpan_update = 0.04; # days between reload of full CPAN index
my $ua;
sub safe_copy($$);
sub cpan_index($@);
sub register($$$);
sub package_inventory($$;$);
sub package_on_usual_location($);
sub inspect_archive;
sub inspect_tar_archive($$);
sub inspect_zip_archive($$);
sub collect_package_details($$$);
sub update_global_cpan($$);
sub load_file($$);
sub merge_global_cpan($$$);
sub create_details($$$$$);
sub calculate_checksums($$);
sub read_details($);
sub remove_expired_details($$$);
sub mkdirhier(@);
sub cpan_mirror($$$@);
sub safe_copy($$)
{ my ($from, $to) = @_;
trace "copy $from to $to";
copy $from, $to
or fault __x"cannot copy {from} to {to}", from => $from, to => $to;
}
sub cpan_index($@)
{ my ($mycpan, $globalcpan, %opts) = @_;
my $lazy = $opts{lazy};
my $fallback = $opts{fallback};
my $undefs = exists $opts{undefs} ? $opts{undefs} : 1;
lib/CPAN/Site/Index.pm view on Meta::CPAN
#
# global variables for testing purposes (sorry)
our ($topdir, $findpkgs, %finddirs, $olddists, $index_age);
sub register($$$)
{ my ($package, $this_version, $dist) = @_;
# warn "register $package, " . (defined $this_version ? $this_version : 'undef');
if(ref $this_version)
lib/CPAN/Site/Index.pm view on Meta::CPAN
&& $registered_version > $this_version;
$findpkgs->{$package} = [ $this_version, $dist ];
}
sub package_inventory($$;$)
{ (my $mycpan, $olddists, $index_age) = @_; #!!! see "my"
$topdir = catdir $mycpan, 'authors', 'id';
mkdirhier $topdir;
$findpkgs = {};
lib/CPAN/Site/Index.pm view on Meta::CPAN
find {wanted => \&inspect_archive, no_chdir => 1}, $topdir;
($findpkgs, \%finddirs);
}
sub package_on_usual_location($)
{ my $file = shift;
my ($top, $subdir, @rest) = splitdir $file;
defined $subdir or return 0;
!@rest # path is at top-level of distro
lib/CPAN/Site/Index.pm view on Meta::CPAN
return inspect_zip_archive $dist, $fn
if $fn =~ $zip;
}
sub inspect_tar_archive($$)
{ my ($dist, $fn) = @_;
my $arch = Archive::Tar->new;
$arch->read($fn, 1)
or error __x"no files in tar archive '{fn}': {err}"
lib/CPAN/Site/Index.pm view on Meta::CPAN
or next;
collect_package_details $fn, $dist, $file->get_content_by_ref;
}
}
sub inspect_zip_archive($$)
{ my ($dist, $fn) = @_;
my $arch = Archive::Zip->new;
$arch->read($fn)==AZ_OK
or error __x"no files in zip archive '{fn}': {err}"
lib/CPAN/Site/Index.pm view on Meta::CPAN
, fn => $fn, err => $status;
collect_package_details $fn, $dist, \$contents;
}
}
sub collect_package_details($$$)
{ my ($fn, $dist) = (shift, shift);
my @lines = split /\r?\n/, ${shift()};
my $in_pod = 0;
my $package;
local $VERSION = undef; # may get destroyed by eval
lib/CPAN/Site/Index.pm view on Meta::CPAN
$VERSION = $VERSION->numify if ref $VERSION;
register $package, $VERSION, $dist
if defined $package;
}
sub update_global_cpan($$)
{ my ($mycpan, $globalcpan) = @_;
my $global = catdir $mycpan, 'global';
my ($mailrc, $globdetails, $modlist) =
map { catfile $global, $_ }
lib/CPAN/Site/Index.pm view on Meta::CPAN
load_file "$globalcpan/modules/02packages.details.txt.gz", $globdetails;
load_file "$globalcpan/modules/03modlist.data.gz", $modlist;
$globdetails;
}
sub load_file($$)
{ my ($from, $to) = @_;
my $response = $ua->get($from, ':content_file' => $to);
return if $response->is_success;
unlink $to;
error __x"failed to get {uri} for {to}: {err}"
, uri => $from, to => $to, err => $response->status_line;
}
sub merge_global_cpan($$$)
{ my ($mycpan, $pkgs, $globdetails) = @_;
trace "merge packages with CPAN core list in $globdetails";
my $cpan_pkgs = read_details $globdetails;
lib/CPAN/Site/Index.pm view on Meta::CPAN
$pkgs->{$pkg} = [$version, $cpandist];
}
}
}
sub create_details($$$$$)
{ my ($details, $filename, $pkgs, $lazy, $undefs) = @_;
trace "creating package details in $filename";
my $fh = IO::Zlib->new($filename, 'wb')
or fault __x"generating gzipped {fn}", fn => $filename;
lib/CPAN/Site/Index.pm view on Meta::CPAN
$path =~ s,\\,/,g;
$fh->printf("%-30s\t%s\t%s\n", $pkg, $version, $path);
}
}
sub calculate_checksums($$)
{ my $dirs = shift;
my $root = shift;
trace "updating checksums";
foreach my $dir (keys %$dirs)
lib/CPAN/Site/Index.pm view on Meta::CPAN
updatedir($dir, $root)
or warning 'failed calculating checksums in {dir}', dir => $dir;
}
}
sub read_details($)
{ my $fn = shift;
-f $fn or return {};
trace "collecting all details from $fn";
my $fh = IO::Zlib->new($fn, 'rb')
lib/CPAN/Site/Index.pm view on Meta::CPAN
}
\%dists;
}
sub remove_expired_details($$$)
{ my ($mycpan, $dists, $newer) = @_;
trace "extracting only existing local distributions";
my $authors = catdir $mycpan, 'authors', 'id';
foreach my $dist (keys %$dists)
lib/CPAN/Site/Index.pm view on Meta::CPAN
delete $dists->{$dist};
}
}
}
sub mkdirhier(@)
{ foreach my $dir (@_)
{ next if -d $dir;
mkdirhier dirname $dir;
mkdir $dir, 0755
lib/CPAN/Site/Index.pm view on Meta::CPAN
trace "created $dir";
}
1;
}
sub cpan_mirror($$$@)
{ my ($mycpan, $globalcpan, $mods, %opts) = @_;
@$mods or return;
my %need = map { ($_ => 1) } @$mods;
my $auth = catdir $mycpan, 'authors', 'id';
view release on metacpan or search on metacpan
sub _mod2pm { (my $mod = shift) =~ s{::}{/}g; return "$mod.pm" }
sub _path2mod { (my $pm = shift) =~ s{/}{::}g; return substr $pm, 5, -3 }
sub _mod2dist { (my $mod = shift) =~ s{::}{-}g; return $mod; }
sub _slurp { do { local (@ARGV,$/)=$_[0]; <> } }
sub capture(&) {
my $callback = shift;
my $output;
open my $fh, '>', \$output;
my $old = select $fh;
eval { $callback->() };
view release on metacpan or search on metacpan
lib/CPAN/Testers/API.pm view on Meta::CPAN
#pod ]
#pod }
#pod
#pod =cut
sub render_error( $c, $status, @errors ) {
return $c->render(
status => $status,
openapi => {
errors => [
map { !ref $_ ? { message => $_, path => '/' } : $_ } @errors,
view release on metacpan or search on metacpan
lib/CPAN/Testers/Backend/Fix/TesterNoname.pm view on Meta::CPAN
is => 'ro',
isa => InstanceOf['DBI::db'],
required => 1,
);
sub run( $self, @args ) {
my ( $email, @name ) = @args;
die "Email and name are required" unless $email && @name;
my $name = join " ", @name;
$self->schema->resultset( 'MetabaseUser' )
view release on metacpan or search on metacpan
lib/CPAN/Testers/Schema.pm view on Meta::CPAN
#pod directory. These versions can then be upgraded to using the
#pod L<cpantesters-schema> script.
#pod
#pod =cut
sub ordered_schema_versions( $self ) {
my @versions =
uniq sort
map { /[\d.]+-([\d.]+)/ }
grep { /CPAN-Testers-Schema-[\d.]+-[\d.]+-MySQL[.]sql/ }
path( dist_dir( 'CPAN-Testers-Schema' ) )->children;
lib/CPAN/Testers/Schema.pm view on Meta::CPAN
#pod
#pod =back
#pod
#pod =cut
sub populate_from_api( $self, $search, @tables ) {
my $ua = $self->{_ua} ||= Mojo::UserAgent->new;
$ua->inactivity_timeout( 120 );
my $base_url = $self->{_url} ||= 'http://api.cpantesters.org/v3';
my $dtf = DateTime::Format::ISO8601->new();
view release on metacpan or search on metacpan
inc/Test/More.pm view on Meta::CPAN
$Test->unlike(@_);
}
sub cmp_ok($$$;$) {
$Test->cmp_ok(@_);
}
view release on metacpan or search on metacpan
lib/CPAN2RT.pm view on Meta::CPAN
use List::Compare;
use CPAN::DistnameInfo;
use List::MoreUtils qw(uniq);
our $DEBUG = 0;
sub debug(&);
=head1 METHODS
=head2 new
lib/CPAN2RT.pm view on Meta::CPAN
while ( my $str = <$fh> ) {
return if $str =~ /^\s*$/;
}
}
sub debug(&) {
return unless $DEBUG;
print STDERR map { /\n$/? $_ : $_."\n" } $_[0]->();
}
1;
view release on metacpan or search on metacpan
lib/CPANPLUS/Dist/Arch.pm view on Meta::CPAN
my ($pkgname, $pkgver) = split / /, $result;
$pkgver =~ s/-\d+\z//; # remove the package revision number
return ($pkgname, $pkgver);
}
sub _unique(@)
{
my %seen;
return map { $seen{$_}++ ? () : $_ } @_;
}
view release on metacpan or search on metacpan
lib/CPANPLUS/Shell/Wx/util.pm view on Meta::CPAN
sub _uGetModDir{
my $mod=shift;
}
#TODO this method populates a tree with the given array ref
sub _uPopulateModules($$){
my $tree=shift;
my $aref=shift;
}
#@return the time in readable - mm:ss - format
lib/CPANPLUS/Shell/Wx/util.pm view on Meta::CPAN
#@usage:
# use util qw/_uGetTimed/;
# my $begin=time();
# {... code to be timed ...}
# my $totalTime=_uGetTimed($begin);
sub _uGetTimed($){
my $begin=shift;
mu $end=time();
return sprintf("%2d",(($end-$begin)/60)).":".sprintf("%2d",(($end-$begin) % 60));
}
view release on metacpan or search on metacpan
lib/CPANPLUS/YACSmoke/SortVers.pm view on Meta::CPAN
@ISA=qw(Exporter);
@EXPORT=qw(&versions &versioncmp);
@EXPORT_OK=qw();
sub versioncmp( $$ ) {
my @A = ($_[0] =~ /([-.]|\d+|[^-.\d]+)/g);
my @B = ($_[1] =~ /([-.]|\d+|[^-.\d]+)/g);
my ($A, $B);
while (@A and @B) {
lib/CPANPLUS/YACSmoke/SortVers.pm view on Meta::CPAN
}
}
@A <=> @B;
}
sub versions() {
my $callerpkg = (caller)[0];
my $caller_a = "${callerpkg}::a";
my $caller_b = "${callerpkg}::b";
no strict 'refs';
return versioncmp($$caller_a, $$caller_b);
view release on metacpan or search on metacpan
inc/bundle/JSON/PP.pm view on Meta::CPAN
($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
}
# Obsoleted
sub to_json($) {
Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
}
sub from_json($) {
Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
}
# Methods
view release on metacpan or search on metacpan
CPS function which requires more than one continuation, because there is no
way to distinguish the different named returns.
=cut
sub liftk(&)
{
my ( $code ) = @_;
return sub {
my $k = pop;
returned function is invoked, it repeatedly calls the block or wait function,
until the CPS function has invoked its continuation.
=cut
sub dropk(&$)
{
my ( $waitfunc, $kfunc ) = @_;
return sub {
my @result;
view release on metacpan or search on metacpan
example/linux-xsub-hello-world.pl view on Meta::CPAN
MAP_ANONYMOUS => 32,
};
# I don't know of a pure-perl way to write to an arbitrary memory location,
# but this works for linux :-)
sub memcpy($dst_addr, $src_sv, $size=length $src_sv) {
if (-w '/proc/self/mem') {
open my $mem, '+>', '/proc/self/mem' or die "open(/dev/mem): $!";
$mem->sysseek($dst_addr, 0) == $dst_addr or die "sysseek: $!";
$mem->syswrite($src_sv, $size) == $size or die "write: $!";
} else {
view release on metacpan or search on metacpan
lib/CSS/DOM/Util.pm view on Meta::CPAN
unescape_url
unescape_str escape_str';
our %EXPORT_TAGS = (all=>\@EXPORT_OK);
sub escape($$) {
my $str = shift;
my $hex_or_space = qr/[0-9a-fA-F]|(?!$_[0])[ \t]/;
$str =~ s/([\n\r\f]|$_[0])/
my $c = $1;
$c =~ m'[ -\/:-@[-`{-~]'
lib/CSS/DOM/Util.pm view on Meta::CPAN
), ord $c
/ge;
$str;
}
sub unescape($) {
my $val = shift;
$val =~ s/\\(?:
([a-fA-F0-9]{1,6})(?:\r\n|[ \n\r\t\f])?
|
([^\n\r\f0-9a-f])
lib/CSS/DOM/Util.pm view on Meta::CPAN
''
/gex;
$val;
}
sub escape_ident($) {
my $str = shift;
# An identifier can’t have [0-9] for the first character, or for
# the second if
# the first is [-].
return escape $str,
qr/([\0-,.\/:-\@[-^`{-\177]|^[0-9]|(?<=^-)[0-9])/;
}
sub unescape_url($) {
my $token = shift;
$token =~ s/^url\([ \t\r\n\f]*//;
$token =~ s/[ \t\r\n\f]*\)\z//;
$token =~ s/^['"]// and chop $token;
return unescape $token
}
sub escape_str($) {
"'" . escape($_[0],qr/'/) . "'"
}
sub unescape_str($) {
unescape substr $_[0], 1, -1;
}
**__END__**
view release on metacpan or search on metacpan
lib/CTK/TFVals.pm view on Meta::CPAN
is_num is_flt is_int is_int8 is_int16 is_int32 is_int64 is_intx
is_void isnt_void is_not_void
/],
);
sub uv2zero($) {
my $v = shift;
return 0 unless defined $v;
return $v;
}
sub uv2null($) {
my $v = shift;
return '' unless defined $v;
return $v;
}
sub uv2empty($) { goto &uv2null }
sub uv2void($) { goto &uv2null }
sub fv2undef($) {
my $v = shift;
return undef unless $v;
return $v;
}
sub fv2zero($) {
my $v = shift;
return 0 unless $v;
return $v;
}
sub fv2null($) {
my $v = shift;
return '' unless $v;
return $v;
}
sub fv2empty($) { goto &fv2null }
sub fv2void($) { goto &fv2null }
sub tv2num($) {
my $tv = shift;
return is_num($tv) ? $tv : 0;
}
sub tv2number($) { goto &tv2num }
sub is_num($) {
my $v = shift;
return 0 unless defined $v;
return 1 if $v =~ /^[+\-]?[0-9]{1,20}$/; # 64 bit
return 0;
}
sub tv2flt($) {
my $tv = shift;
return is_flt($tv) ? $tv : 0;
}
sub tv2float($) { goto &tv2flt }
sub is_flt($) {
my $v = shift;
return 0 unless defined $v;
return 1 if $v =~ /^[+\-]?[0-9]{1,20}\.?[0-9]*$/; # 64 bit min
return 0;
}
sub tv2int($) {
my $tv = shift;
return is_int($tv) ? $tv : 0;
}
sub is_int($) {
my $v = shift;
return 0 unless defined $v;
return 1 if $v =~ /^[0-9]{1,20}$/; # 64 bit max
return 0;
}
sub tv2int8($) {
my $tv = shift;
return is_int8($tv) ? $tv : 0;
}
sub is_int8($) {
my $v = shift;
return 0 unless defined $v;
return 1 if ($v =~ /^[0-9]{1,3}$/) && ($v >= 0) && ($v < 2**8);
return 0;
}
sub tv2int16($) {
my $tv = shift;
return is_int16($tv) ? $tv : 0;
}
sub is_int16($) {
my $v = shift;
return 0 unless defined $v;
return 1 if ($v =~ /^[0-9]{1,5}$/) && ($v >= 0) && ($v < 2**16);
return 0;
}
sub tv2int32($) {
my $tv = shift;
return is_int32($tv) ? $tv : 0;
}
sub is_int32($) {
my $v = shift;
return 0 unless defined $v;
return 1 if ($v =~ /^[0-9]{1,10}$/) && ($v >= 0) && ($v < 2**32);
return 0;
}
sub tv2int64($) {
my $tv = shift;
return is_int64($tv) ? $tv : 0;
}
sub is_int64($) {
my $v = shift;
return 0 unless defined $v;
return 1 if ($v =~ /^[0-9]{1,20}$/) && ($v >= 0) && ($v < 2**64);
return 0;
}
sub tv2intx($$) {
my $tv = shift;
my $x = shift || 0;
return is_intx($tv, $x) ? $tv : 0;
}
sub is_intx($$) {
my $v = shift;
my $x = shift || 0;
return 0 unless $x && is_int8($x) && ($x >=0) && ($x <= 64);
return 0 unless defined $v;
return 1 if ($v =~ /^[0-9]{1,20}$/) && ($v >= 0) && ($v < 2**$x);
view release on metacpan or search on metacpan
ex/get_bim_services.pl view on Meta::CPAN
use JSON;
use CTM::ReadEM 0.181, qw/:all/;
#----> ** fonctions **
sub usage() {
return 'Aide : perldoc ' . basename($0);
}
#----> ** section principale **
view release on metacpan or search on metacpan
lib/CWB/CQI/Client.pm view on Meta::CPAN
croak "cqi_read_string(): $!"
unless defined recv $conn, $msg, $len, MSG_WAITALL;
return $msg;
}
sub cqi_read_byte_list() {
my ($i, $len, @list);
$len = cqi_read_int();
for ($i = $len; $i > 0; $i--) {
push @list, cqi_read_byte;
}
return @list;
}
sub cqi_read_word_list() {
my ($i, $len, @list);
$len = cqi_read_int();
for ($i = $len; $i > 0; $i--) {
push @list, cqi_read_word();
}
return @list;
}
sub cqi_read_int_list() {
my ($i, $len, @list);
$len = cqi_read_int();
for ($i = $len; $i > 0; $i--) {
push @list, cqi_read_int();
}
return @list;
}
sub cqi_read_string_list() {
my ($i, $len, @list);
$len = cqi_read_int();
for ($i = $len; $i > 0; $i--) {
push @list, cqi_read_string();
}
return @list;
}
sub cqi_read_int_table() {
my $rows = cqi_read_int();
my $columns = cqi_read_int();
my @table = ();
for (my $i = 0; $i < $rows; $i++) {
my @line = ();
view release on metacpan or search on metacpan
lib/CWB/CQP/More.pm view on Meta::CPAN
Use this method to specify what annotations to make CQP to show. Pass
it a list of the annotation names.
=cut
sub annotation_show($@) {
my ($self, @annotations) = @_;
my $annots = join(" ", map { "+$_" } @annotations);
$self->exec("show $annots;");
}
lib/CWB/CQP/More.pm view on Meta::CPAN
Use this method to specify what annotations to make CQP to not show
(hide). Pass it a list of the annotation names.
=cut
sub annotation_hide($@) {
my ($self, @annotations) = @_;
my $annots = join(" ", map { "-$_" } @annotations);
$self->exec("show $annots;");
}
lib/CWB/CQP/More.pm view on Meta::CPAN
Change current active corpus. Pass the corpus name as the argument.
=cut
sub change_corpus($$) {
my ($self, $cname) = @_;
$cname = uc $cname;
$self->exec("$cname;");
}
lib/CWB/CQP/More.pm view on Meta::CPAN
set. Note that at the moment string values should be double quoted
(see example in the synopsis).
=cut
sub set($%) {
my ($self, %vars) = @_;
for my $key (keys %vars) {
my $values;
if (ref($vars{$key}) eq "ARRAY") {
$values = join(" ", @{$vars{$key}});
view release on metacpan or search on metacpan
else {
return undef;
}
}
sub add_attribute( $$$ ) {
my ($self, $name, $type) = @_;
die "CWB::RegistryFile: invalid attribute type '$type' for attribute $name\n"
unless $type =~ /^[PpSsAa]$/;
$type = lc $type;
my $previous = $self->{ATT}->{$name}; # check if attribute is already defined
view release on metacpan or search on metacpan
lib/CXC/DB/DDL/Util.pm view on Meta::CPAN
sub db_version( $dbh ) {
my $dbd = $dbh->{Driver}->{Name};
return $dbd eq DBD_POSTGRESQL
? $dbh->{pg_server_version}
view release on metacpan or search on metacpan
t/Sequence/Linear/sequence.t view on Meta::CPAN
$ctx->release;
};
}
sub test(@) {
my $ctx = context;
test_one( @$_ ) foreach @_;
$ctx->release;
}
view release on metacpan or search on metacpan
lib/CaCORE/ApplicationService.pm view on Meta::CPAN
);
@ISA = qw(Exporter);
# create an xml string based on my attributes
sub toWebserviceXML() {
}
# populate my own attributs given a webservice result
sub fromWebserviceXML() {
}
##########################################################################################
package CaCORE::DomainObjectFac;
view release on metacpan or search on metacpan
Not implemented
Exception: yes
=cut
sub _CacPop($) {
die "_CacPop not implemented.";
}
=item $val = _CacPopDbl()
Currently not implemented
Exception: yes
=cut
sub _CacPopList()
{
die "_CacPopList is currently not implemented - sorry.";
}
=item $oref = _CacPopOref()
Not Implemented
Exception: yes
=cut
sub _CacPopPtr() {
die "_CacPopPtr is currently not implemented";
}
=item _CacPushClassMethod $classname, $methodname, [$flag]/