Result:
found more than 877 distributions - search limited to the first 2001 files matching your query
( run in 0.551 )
Apporo
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(@_);
}
Arabic
view release on metacpan or search on metacpan
lib/Arabic.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 Arabic::escape_script;
# 6.18. Matching Multiple-Byte Characters
Arango-Tango
view release on metacpan or search on metacpan
lib/Arango/Tango/API.pm view on Meta::CPAN
use Sub::Install qw(install_sub);
use Sub::Name qw(subname);
sub _install_methods($$) {
my ($package, $methods) = @_;
for my $method (keys %$methods) {
my $value = $methods->{$method};
install_sub {
into => $package,
Arch
view release on metacpan or search on metacpan
perllib/Arch/Test/Tree.pm view on Meta::CPAN
$self->run_tla('add-id', $fname);
return $fname;
}
sub modify_file($$;$) {
my $self = shift;
my $file = shift;
my $content = shift || Arch::Util::load_file($self->root . "/$file")
. "Has been modified.\n";
Archer
view release on metacpan or search on metacpan
sub init {
$FindBin::Bin .= "/.." if $FindBin::Bin !~ m!/\.\.!;
$t::Plugin::Dummy::RUN_COUNTER = 0;
}
sub capture(&) {
my $code = shift;
$ERR = undef;
$OUT = undef;
Archive-AndroidBackup
view release on metacpan or search on metacpan
lib/Archive/AndroidBackup.pm view on Meta::CPAN
=> message {"Encryption not implemented"};
has 'encryption' => ( is => 'rw', isa => 'HdrEncryption', lazy => 1, default => "");
sub _readHdrLine($$)
{
my ($self, $FH) = @_;
my ($buf, $c) = (('') x 2);
while ((read($FH, $c, 1) > 0) && ($c ne "\n")) {
$buf .= $c;
}
$buf;
}
sub read_header($)
{
my ($self, $FH) = @_;
$self->magic($self->_readHdrLine($FH));
$self->version($self->_readHdrLine($FH));
$self->compression($self->_readHdrLine($FH));
$self->encryption($self->_readHdrLine($FH));
}
sub write_header($)
{
my ($self, $FH) = @_;
$self->magic("ANDROID BACKUP");
$self->version(1);
Archive-BagIt
view release on metacpan or search on metacpan
lib/Archive/BagIt/Role/Manifest.pm view on Meta::CPAN
load_class($class);
$class->import( 'parallel_map' );
return 1;
}
sub check_pluggable_modules() {
my $self = shift;
return ($self->has_parallel_support() && $self->has_async_support());
}
Archive-Cpio
view release on metacpan or search on metacpan
lib/Archive/Cpio/Common.pm view on Meta::CPAN
use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(padding write_or_die max begins_with);
sub magics() {
{
"070707" => 'ODC',
"070701" => 'NewAscii',
"\xC7\x71" => 'OldBinary', # swabbed 070707
"\x71\xC7" => 'OldBinary', # 070707
Archive-Zip
view release on metacpan or search on metacpan
lib/Archive/Zip/BufferedFileHandle.pm view on Meta::CPAN
substr($$buf, $offset, $bytesWritten);
$self->{size} = length($self->{content});
return $bytesWritten;
}
sub clearerr() { 1 }
1;
Archlinux-Term
view release on metacpan or search on metacpan
t/01-colors.t view on Meta::CPAN
use Test::More tests => 5;
use Archlinux::Term qw(:all);
my %CODE_OF = ( 'red' => 31, 'green' => 32, 'yellow' => 33, 'blue' => 34, );
sub output_of(&)
{
my ($code_ref) = @_;
open my $old_stdout, '>&STDOUT' or die "open: $!";
my $out_buffer;
Arithmetic-PaperAndPencil
view release on metacpan or search on metacpan
lib/Arithmetic/PaperAndPencil/Number.pm view on Meta::CPAN
, value => substr($value, 0, $self->chars - $len)
);
}
}
sub max_unit($radix) {
if ($radix < 2 or $radix > 36) {
croak("Radix $radix should be between 2 and 36");
}
return Arithmetic::PaperAndPencil::Number->new(radix => $radix, value => $digits[$radix - 1]);
}
lib/Arithmetic/PaperAndPencil/Number.pm view on Meta::CPAN
my $tens = $digit_value{$self->carry->value};
my $units = $digit_value{$self->unit ->value};
return $tens * $self->radix + $units;
}
sub add($x, $y, $invert) {
my $radix = $x->radix;
if ($radix != $y->radix) {
croak("Addition not allowed with different bases: $radix @{[$y->radix]}");
}
if ($x->chars != 1 and $y->chars != 1) {
lib/Arithmetic/PaperAndPencil/Number.pm view on Meta::CPAN
return Arithmetic::PaperAndPencil::Number->new(
radix => $radix
, value => join('', reverse(@long_op)));
}
sub minus($x, $y, $invert) {
if ($invert) {
($x, $y) = ($y, $x);
}
my $radix = $x->radix;
if ($radix != $y->radix) {
lib/Arithmetic/PaperAndPencil/Number.pm view on Meta::CPAN
my $y10 = $y->_native_int;
my $z10 = $x10 - $y10;
return Arithmetic::PaperAndPencil::Number->new(radix => $radix, value => $digits[$z10]);
}
sub times($x, $y, $invert) {
if ($invert) {
($x, $y) = ($y, $x);
}
my $radix = $x->radix;
if ($radix != $y->radix) {
lib/Arithmetic/PaperAndPencil/Number.pm view on Meta::CPAN
my $zt = floor($z10 / $radix);
return Arithmetic::PaperAndPencil::Number->new(value => $digits[$zt] . $digits[$zu]
, radix => $radix);
}
sub divide($x, $y, $invert) {
if ($invert) {
($x, $y) = ($y, $x);
}
my $radix = $x->radix;
if ($radix != $y->radix) {
lib/Arithmetic/PaperAndPencil/Number.pm view on Meta::CPAN
else {
return Arithmetic::PaperAndPencil::Number->new(radix => $radix, value => $digits[$qq]);
}
}
sub num_cmp($x, $y, $invert) {
my $radix = $x->radix;
if ($radix != $y->radix) {
croak("Comparison not allowed with different bases: $radix @{[$y->radix]}");
}
return $x->chars <=> $y->chars
||
$x->value cmp $y->value;
}
sub alpha_cmp($x, $y, $invert) {
my $radix = $x->radix;
if ($radix != $y->radix) {
croak("Comparison not allowed with different bases: $radix @{[$y->radix]}");
}
return $x->value cmp $y->value;
Ark
view release on metacpan or search on metacpan
t/004_forward.t view on Meta::CPAN
}
require Ark::Test;
sub run_tests() {
{
my $res = request( GET => '/root/one' );
ok( $res->is_success, 'request ok');
is( $res->content, 'one_two_tree_four_five_six_', 'forward ok');
}
Armadito-Agent
view release on metacpan or search on metacpan
lib/Armadito/Agent/HTTP/Client/ArmaditoAV.pm view on Meta::CPAN
}
return $self->request($request);
}
sub _handleRegisterResponse() {
my ( $self, $response ) = @_;
$self->{logger}->info( $response->content() );
my $obj = from_json( $response->content(), { utf8 => 1 } );
lib/Armadito/Agent/HTTP/Client/ArmaditoAV.pm view on Meta::CPAN
die "Unable to unregister to ArmaditoAV api." if ( !$response->is_success() );
return $self;
}
sub _handleJsonResponse() {
my ( $self, $response ) = @_;
$self->{logger}->debug( $response->content() );
return from_json( $response->content(), { utf8 => 1 } );
Array-AllUtils
view release on metacpan or search on metacpan
lib/Array/AllUtils.pm view on Meta::CPAN
goto &Exporter::import;
}
# BEGIN_BLOCK: first
sub first(&$) {
my $code = shift;
for (@{$_[0]}) {
return $_ if $code->($_);
}
undef;
}
# END_BLOCK: first
# BEGIN_BLOCK: firstidx
sub firstidx(&$) {
my $code = shift;
my $i = 0;
for (@{$_[0]}) {
return $i if $code->($_);
$i++;
Array-Assign
view release on metacpan or search on metacpan
lib/Array/Assign.pm view on Meta::CPAN
shift;
goto &arry_extract_i;
}
sub arry_assign_s(\@$%) {
my ($target,$mapping,%assignments) = @_;
while (my ($name,$value) = each %assignments) {
my $idx = $mapping->{$name};
die("Unknown name '$name'") unless defined $idx;
$target->[$idx] = $value;
}
$target;
}
sub arry_assign_i(\@%)
{
my ($target,%mappings) = @_;
_idx_sanity_check(%mappings);
@{$target}[keys %mappings] = values %mappings;
}
sub arry_extract_i(\@%)
{
my ($source,%targets) = @_;
_idx_sanity_check(%targets);
while ( my ($idx,$ref) = each %targets) {
$$ref = $source->[$idx];
}
}
sub arry_extract_s(\@$%) {
my ($source,$mappings,%targets) = @_;
while (my ($name,$ref) = each %targets) {
my $idx = $mappings->{$name};
if(!defined $idx) {
die("unknown parameter '$name'");
Array-Columnize
view release on metacpan or search on metacpan
lib/Array/Columnize/columnize.pm view on Meta::CPAN
Return the length of String I<cell>. If Boolean I<term_adjust> is true,
ignore terminal sequences in I<cell>.
=cut
sub cell_size($$) {
my ($cell, $term_adjust) = @_;
$cell =~ s/\e\[.*?m//g if $term_adjust;
return length($cell);
}
lib/Array/Columnize/columnize.pm view on Meta::CPAN
set false, consecutive items will go across, left to right, top to
bottom.
=cut
sub columnize($;$) {
my($aref, $opts) = @_;
my @l = @$aref;
# Some degenerate cases
# FIXME test for arrayness
Array-Extract
view release on metacpan or search on metacpan
lib/Array/Extract.pm view on Meta::CPAN
the array is a tied object with a class such as
Tie::File)
=cut
sub extract(&\@) {
my $block = shift;
my $array = shift;
# loop invariants. The element we're currently on
# and the length of the array
Array-PrintCols
view release on metacpan or search on metacpan
PrintCols.pm view on Meta::CPAN
@ISA = (Exporter);
@EXPORT = qw( print_cols format_cols );
use Carp;
sub min(@);
sub max(@);
$PreSorted = 1; # if set, do not need to sort
# If users need to, they can set this variable externally:
#
PrintCols.pm view on Meta::CPAN
# Thanks to Gisle Aas <aas@bergen.sn.no> for the suggestion)
#
# Routine to format an array of values in alphabetically vertically
# sorted columns.
sub format_cols($;@) {
my($array) = shift;
$array = $$array if ref($array) eq 'REF';
$array = [sort(keys(%$array))] if ref($array) eq 'HASH';
ref($array) eq 'ARRAY' or croak "arg 1 must be an ARRAY, HASH, or ARRAYREF\n";
my($col_width) = shift || 0;
PrintCols.pm view on Meta::CPAN
$o;
}
# print_cols -- just print the results of format_cols.
sub print_cols($;@) {
my $aref = shift;
print format_cols($aref,@_);
}
sub min(@) {
my($min) = shift;
local($_);
foreach (@_) { $min = $_ if $min > $_; }
$min;
}
sub max(@) {
my($max) = shift;
local($_);
foreach (@_) { $max = $_ if $max < $_; }
$max;
}
Array-Slice
view release on metacpan or search on metacpan
our @EXPORT_OK = qw(reset slice);
our %EXPORT_TAGS = ( all => \@EXPORT_OK);
bootstrap Array::Slice $VERSION;
sub slice(\@;$) { array_slice( $_[0], $#_ ? $_[1] : howmany) }
1;
=pod
Array-Tour
view release on metacpan or search on metacpan
lib/Array/Tour.pm view on Meta::CPAN
Take the parameters provided to new() and use them to set the
attributes of the touring object.
=cut
sub _set()
{
my $self = shift;
my(%params) = @_;
warn "Unknown paramter $_" foreach (grep{$_ !~ /reverse/} (keys %params));
Array-Unique
view release on metacpan or search on metacpan
benchmark.pl view on Meta::CPAN
#my $ar = shift;
return scalar grep {$value eq $_} @_;
}
sub ina2($\@) {
my $value = shift;
my $ar = shift;
foreach my $v (@$ar) {
return 1 if ($v eq $value);
Array-Util-MultiTarget
view release on metacpan or search on metacpan
lib/Array/Util/MultiTarget.pm view on Meta::CPAN
mtremoveallstr
mtremovenum
mtremoveallnum
);
sub mtpop($) {
my $arys = shift;
my @res;
for my $ary (@$arys) { push @res, pop @$ary }
@res;
}
sub mtpush($@) {
my $arys = shift;
for my $ary (@$arys) { push @$ary, @_ }
}
sub mtsplice($$;$@) {
my $arys = shift;
my $offset = shift;
my $len; $len = shift if @_;
my @res;
Array-Utils
view release on metacpan or search on metacpan
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our $VERSION = '0.5';
sub unique(@) {
return keys %{ {map { $_ => undef } @_}};
}
sub intersect(\@\@) {
my %e = map { $_ => undef } @{$_[0]};
return grep { exists( $e{$_} ) } @{$_[1]};
}
sub array_diff(\@\@) {
my %e = map { $_ => undef } @{$_[1]};
return @{[ ( grep { (exists $e{$_}) ? ( delete $e{$_} ) : ( 1 ) } @{ $_[0] } ), keys %e ] };
}
sub array_minus(\@\@) {
my %e = map{ $_ => undef } @{$_[1]};
return grep( ! exists( $e{$_} ), @{$_[0]} );
}
1;
Array-Windowed
view release on metacpan or search on metacpan
lib/Array/Windowed.pm view on Meta::CPAN
&array_windowed(\@array, 0, 26);
=cut
sub array_windowed(\@$$) {
my $array_ref = shift;
my $start = shift;
my $count = shift;
my $first_index = max(0, $start);
Asm-C
view release on metacpan or search on metacpan
lib/Asm/C.pm view on Meta::CPAN
#D2 Structures # Extract structure details from C programs.
my %extractCStructure; # Structured extracted from C files
sub extractCStructure($) # Extract the details of a structure
{my ($input) = @_; # Input C file - a temporary one is ok
return $extractCStructure{$input} if exists $extractCStructure{$input}; # Return cached value if it exists
return undef unless confirmHasCommandLineCommand(q(gcc)); # Check that we have gcc
lib/Asm/C.pm view on Meta::CPAN
}
$extractCStructure{$input} = \%s # Structure details
} # extractCStructure
sub extractCField($$$) # Extract the details of a field in a structure in a C file
{my ($input, $structure, $field) = @_; # Input file, structure name, field within structure
if (my $s = extractCStructure $input) # Structures in file
{if (my $S = $$s{$structure}) # Found structure
{if (my $F = $S->fields) # Structure has fields
{return $$F{$field}; # Field detail
lib/Asm/C.pm view on Meta::CPAN
}
}
undef # Parse failed or no such structure
} # extractCField
sub extractCFieldLoc($$$) # Extract the offset to the location of a field in a structure in a C file
{my ($input, $structure, $field) = @_; # Input file, structure name, field within structure
if (my $f = extractCField($input, $structure, $field)) # Structures in file
{return $f->loc; # Offset to field location
}
undef # Parse failed or no such structure or no such field
} # extractCFieldLoc
sub extractCFieldSize($$$) # Extract the size of a field in a structure in a C file
{my ($input, $structure, $field) = @_; # Input file, structure name, field within structure
if (my $f = extractCField($input, $structure, $field)) # Structures in file
{return $f->size; # Size of field
}
undef # Parse failed or no such structure or no such field
} # extractCFieldSize
sub extractCFieldType($$$) # Extract the type of a field in a structure in a C file
{my ($input, $structure, $field) = @_; # Input file, structure name, field within structure
if (my $f = extractCField($input, $structure, $field)) # Structures in file
{return $f->type; # Type of field
}
undef # Parse failed or no such structure or no such field
} # extractCFieldType
sub extractCStructureFields($$) # Extract the names of the fields in a C structure
{my ($input, $structure) = @_; # Input file, structure name
if (my $s = extractCStructure $input) # Structures in file
{if (my $S = $$s{$structure}) # Found structure
{if (my $F = $S->fields) # Structure has fields
{return sort keys %$F; # Return names of fields in structure in ascending order
lib/Asm/C.pm view on Meta::CPAN
}
}
() # Parse failed or no such structure
} # extractCStructureSize
sub extractCStructureSize($$) # Extract the size of a C structure
{my ($input, $structure) = @_; # Input file, structure name
if (my $s = extractCStructure $input) # Structures in file
{if (my $S = $$s{$structure}) # Found structure
{return $S->size; # Return structure size
}
lib/Asm/C.pm view on Meta::CPAN
#D2 Macros # Extract macro values from C header files
my %extractMacroDefinitionsFromCHeaderFile; # Cache macro definitions
sub extractMacroDefinitionsFromCHeaderFile($) # Extract the macro definitions found in a C header file using gcc
{my ($includeFile) = @_; # C Header file name as it would be entered in a C program
my $d = $extractMacroDefinitionsFromCHeaderFile{$includeFile}; # Cached macro definitions
return $d if $d; # Return cached value
confirmHasCommandLineCommand("gcc"); # Check gcc
lib/Asm/C.pm view on Meta::CPAN
}
$extractMacroDefinitionsFromCHeaderFile{$includeFile} = \%d; # Return definitions
}
sub extractMacroDefinitionFromCHeaderFile($$) # Extract a macro definitions found in a C header file using gcc
{my ($includeFile, $macro) = @_; # C Header file name as it would be entered in a C program, macro name
if (my $d = extractMacroDefinitionsFromCHeaderFile($includeFile)) # Get macro definitions
{return $$d{$macro};
}
undef
Asm-X86
view release on metacpan or search on metacpan
lib/Asm/X86.pm view on Meta::CPAN
# Add a percent character ('%') in front of each element in the array given as a parameter.
# Returns the new array.
#
# =cut
sub _add_percent(@) {
my @result = ();
foreach (@_) {
push @result, "%$_";
}
lib/Asm/X86.pm view on Meta::CPAN
# PRIVATE SUBROUTINE.
# Returns an array of the provided arguments with duplicate entries removed.
#
# =cut
#
sub _remove_duplicates(@) {
# Use a hash to remove the duplicates:
my %new_hash;
foreach (@_) {
$new_hash{$_} = 1;
lib/Asm/X86.pm view on Meta::CPAN
# Removes unnecessary '+' characters from the beginning of the given string.
# Returns the resulting string (or '+' if it was empty).
#
# =cut
#
sub _nopluses($) {
my $elem = shift;
$elem =~ s/^\s*\++//o;
$elem = '+' if $elem eq '';
return $elem;
lib/Asm/X86.pm view on Meta::CPAN
# case-insensitive.
# Returns 1 if yes.
#
# =cut
#
sub _is_in_array($@) {
my $elem = shift;
my $arr = shift;
return 0 unless $elem =~ /^\w+$/o;
foreach (@$arr) {
lib/Asm/X86.pm view on Meta::CPAN
# parameter), case-insensitive.
# Returns 1 if yes.
#
# =cut
#
sub _is_in_array_att($@) {
my $elem = shift;
my $arr = shift;
return 0 unless $elem =~ /^\%\w+$/o;
foreach (@$arr) {
lib/Asm/X86.pm view on Meta::CPAN
}
return 0;
}
sub add_att_suffix_instr(@);
=head2 @regs8_intel
A list of 8-bit registers (as strings) in Intel syntax.
lib/Asm/X86.pm view on Meta::CPAN
Checks if the given string parameter is a valid x86 register (any size) in Intel syntax.
Returns 1 if yes.
=cut
sub is_reg_intel($) {
return _is_in_array (shift, \@regs_intel);
}
=head2 is_reg_att
Checks if the given string parameter is a valid x86 register (any size) in AT&T syntax.
Returns 1 if yes.
=cut
sub is_reg_att($) {
return _is_in_array_att (shift, \@regs_att);
}
=head2 is_reg
Checks if the given string parameter is a valid x86 register (any size).
Returns 1 if yes.
=cut
sub is_reg($) {
my $elem = shift;
return is_reg_intel ($elem) | is_reg_att ($elem);
}
=head2 is_reg8_intel
lib/Asm/X86.pm view on Meta::CPAN
Checks if the given string parameter is a valid x86 8-bit register in Intel syntax.
Returns 1 if yes.
=cut
sub is_reg8_intel($) {
return _is_in_array (shift, \@regs8_intel);
}
=head2 is_reg8_att
Checks if the given string parameter is a valid x86 8-bit register in AT&T syntax.
Returns 1 if yes.
=cut
sub is_reg8_att($) {
return _is_in_array_att (shift, \@regs8_att);
}
=head2 is_reg8
Checks if the given string parameter is a valid x86 8-bit register.
Returns 1 if yes.
=cut
sub is_reg8($) {
my $elem = shift;
return is_reg8_intel ($elem) | is_reg8_att ($elem);
}
=head2 is_reg16_intel
lib/Asm/X86.pm view on Meta::CPAN
Checks if the given string parameter is a valid x86 16-bit register in Intel syntax.
Returns 1 if yes.
=cut
sub is_reg16_intel($) {
return _is_in_array (shift, \@regs16_intel);
}
=head2 is_reg16_att
Checks if the given string parameter is a valid x86 16-bit register in AT&T syntax.
Returns 1 if yes.
=cut
sub is_reg16_att($) {
return _is_in_array_att (shift, \@regs16_att);
}
=head2 is_reg16
Checks if the given string parameter is a valid x86 16-bit register.
Returns 1 if yes.
=cut
sub is_reg16($) {
my $elem = shift;
return is_reg16_intel ($elem) | is_reg16_att ($elem);
}
=head2 is_segreg_intel
lib/Asm/X86.pm view on Meta::CPAN
Checks if the given string parameter is a valid x86 segment register in Intel syntax.
Returns 1 if yes.
=cut
sub is_segreg_intel($) {
return _is_in_array (shift, \@segregs_intel);
}
=head2 is_segreg_att
Checks if the given string parameter is a valid x86 segment register in AT&T syntax.
Returns 1 if yes.
=cut
sub is_segreg_att($) {
return _is_in_array_att (shift, \@segregs_att);
}
=head2 is_segreg
Checks if the given string parameter is a valid x86 segment register.
Returns 1 if yes.
=cut
sub is_segreg($) {
my $elem = shift;
return is_segreg_intel ($elem) | is_segreg_att ($elem);
}
=head2 is_reg32_intel
lib/Asm/X86.pm view on Meta::CPAN
Checks if the given string parameter is a valid x86 32-bit register in Intel syntax.
Returns 1 if yes.
=cut
sub is_reg32_intel($) {
return _is_in_array (shift, \@regs32_intel);
}
=head2 is_reg32_att
Checks if the given string parameter is a valid x86 32-bit register in AT&T syntax.
Returns 1 if yes.
=cut
sub is_reg32_att($) {
return _is_in_array_att (shift, \@regs32_att);
}
=head2 is_reg32
Checks if the given string parameter is a valid x86 32-bit register.
Returns 1 if yes.
=cut
sub is_reg32($) {
my $elem = shift;
return is_reg32_intel ($elem) | is_reg32_att ($elem);
}
=head2 is_addressable32_intel
lib/Asm/X86.pm view on Meta::CPAN
for addressing in Intel syntax.
Returns 1 if yes.
=cut
sub is_addressable32_intel($) {
return _is_in_array (shift, \@addressable32);
}
=head2 is_addressable32_att
lib/Asm/X86.pm view on Meta::CPAN
for addressing in AT&T syntax.
Returns 1 if yes.
=cut
sub is_addressable32_att($) {
return _is_in_array_att (shift, \@addressable32_att);
}
=head2 is_addressable32
lib/Asm/X86.pm view on Meta::CPAN
for addressing.
Returns 1 if yes.
=cut
sub is_addressable32($) {
my $elem = shift;
return is_addressable32_intel ($elem) | is_addressable32_att ($elem);
}
=head2 is_r32_in64_intel
lib/Asm/X86.pm view on Meta::CPAN
subregister of a 64-bit register).
Returns 1 if yes.
=cut
sub is_r32_in64_intel($) {
return _is_in_array (shift, \@r32_in64);
}
=head2 is_r32_in64_att
lib/Asm/X86.pm view on Meta::CPAN
parameter is a 32-bit subregister of a 64-bit register).
Returns 1 if yes.
=cut
sub is_r32_in64_att($) {
return _is_in_array_att (shift, \@r32_in64_att);
}
=head2 is_r32_in64
lib/Asm/X86.pm view on Meta::CPAN
parameter is a 32-bit subregister of a 64-bit register).
Returns 1 if yes.
=cut
sub is_r32_in64($) {
my $elem = shift;
return is_r32_in64_intel ($elem) | is_r32_in64_att ($elem);
}
=head2 is_reg64_intel
lib/Asm/X86.pm view on Meta::CPAN
Checks if the given string parameter is a valid x86 64-bit register in Intel syntax.
Returns 1 if yes.
=cut
sub is_reg64_intel($) {
return _is_in_array (shift, \@regs64_intel);
}
=head2 is_reg64_att
Checks if the given string parameter is a valid x86 64-bit register in AT&T syntax.
Returns 1 if yes.
=cut
sub is_reg64_att($) {
return _is_in_array_att (shift, \@regs64_att);
}
=head2 is_reg64
Checks if the given string parameter is a valid x86 64-bit register.
Returns 1 if yes.
=cut
sub is_reg64($) {
my $elem = shift;
return is_reg64_intel ($elem) | is_reg64_att ($elem);
}
=head2 is_reg_mm_intel
lib/Asm/X86.pm view on Meta::CPAN
register in Intel syntax.
Returns 1 if yes.
=cut
sub is_reg_mm_intel($) {
return _is_in_array (shift, \@regs_mm_intel);
}
=head2 is_reg_mm_att
lib/Asm/X86.pm view on Meta::CPAN
register in AT&T syntax.
Returns 1 if yes.
=cut
sub is_reg_mm_att($) {
return _is_in_array_att (shift, \@regs_mm_att);
}
=head2 is_reg_mm
Checks if the given string parameter is a valid x86 multimedia (MMX/3DNow!/SSEn) register.
Returns 1 if yes.
=cut
sub is_reg_mm($) {
my $elem = shift;
return is_reg_mm_intel ($elem) | is_reg_mm_att ($elem);
}
=head2 is_reg_fpu_intel
lib/Asm/X86.pm view on Meta::CPAN
Checks if the given string parameter is a valid x86 FPU register in Intel syntax.
Returns 1 if yes.
=cut
sub is_reg_fpu_intel($) {
return _is_in_array (shift, \@regs_fpu_intel);
}
=head2 is_reg_fpu_att
Checks if the given string parameter is a valid x86 FPU register in AT&T syntax.
Returns 1 if yes.
=cut
sub is_reg_fpu_att($) {
return _is_in_array_att (shift, \@regs_fpu_att);
}
=head2 is_reg_fpu
Checks if the given string parameter is a valid x86 FPU register.
Returns 1 if yes.
=cut
sub is_reg_fpu($) {
my $elem = shift;
return is_reg_fpu_intel ($elem) | is_reg_fpu_att ($elem);
}
=head2 is_reg_opmask_intel
lib/Asm/X86.pm view on Meta::CPAN
Checks if the given string parameter is a valid x86 opmask register in Intel syntax.
Returns 1 if yes.
=cut
sub is_reg_opmask_intel($) {
return _is_in_array (shift, \@regs_opmask_intel);
}
=head2 is_reg_opmask_att
Checks if the given string parameter is a valid x86 opmask register in AT&T syntax.
Returns 1 if yes.
=cut
sub is_reg_opmask_att($) {
return _is_in_array_att (shift, \@regs_opmask_att);
}
=head2 is_reg_opmask
Checks if the given string parameter is a valid x86 opmask register.
Returns 1 if yes.
=cut
sub is_reg_opmask($) {
my $elem = shift;
return is_reg_opmask_intel ($elem) | is_reg_opmask_att ($elem);
}
=head2 is_reg_bound_intel
lib/Asm/X86.pm view on Meta::CPAN
Checks if the given string parameter is a valid x86 bound register in Intel syntax.
Returns 1 if yes.
=cut
sub is_reg_bound_intel($) {
return _is_in_array (shift, \@regs_bound_intel);
}
=head2 is_reg_bound_att
Checks if the given string parameter is a valid x86 bound register in AT&T syntax.
Returns 1 if yes.
=cut
sub is_reg_bound_att($) {
return _is_in_array_att (shift, \@regs_bound_att);
}
=head2 is_reg_bound
Checks if the given string parameter is a valid x86 bound register.
Returns 1 if yes.
=cut
sub is_reg_bound($) {
my $elem = shift;
return is_reg_bound_intel ($elem) | is_reg_bound_att ($elem);
}
=head2 is_instr_intel
lib/Asm/X86.pm view on Meta::CPAN
Checks if the given string parameter is a valid x86 instruction in Intel syntax.
Returns 1 if yes.
=cut
sub is_instr_intel($) {
return _is_in_array (shift, \@instr_intel);
}
=head2 is_instr_att
Checks if the given string parameter is a valid x86 instruction in AT&T syntax.
Returns 1 if yes.
=cut
sub is_instr_att($) {
return _is_in_array (shift, \@instr_att);
}
=head2 is_instr
Checks if the given string parameter is a valid x86 instruction in any syntax.
Returns 1 if yes.
=cut
sub is_instr($) {
my $elem = shift;
return is_instr_intel ($elem) | is_instr_att ($elem);
}
##############################################################################
lib/Asm/X86.pm view on Meta::CPAN
# mode in Intel syntax.
# Returns 1 if yes.
#
# =cut
#
sub _is_valid_16bit_addr_reg_intel($) {
my $reg = shift;
return 1 if $reg =~ /^bx$/io || $reg =~ /^bp$/io
|| $reg =~ /^si$/io || $reg =~ /^di$/io;
return 0;
lib/Asm/X86.pm view on Meta::CPAN
# mode in Intel syntax at the same time because they're of the same type.
# Returns 1 if yes.
#
# =cut
#
sub _is_same_type_16bit_addr_reg_intel($$) {
my $reg1 = shift;
my $reg2 = shift;
return 1 if ($reg1 =~ /^b.$/io && $reg2 =~ /^b.$/io)
|| ($reg1 =~ /^.i$/io && $reg2 =~ /^.i$/io);
lib/Asm/X86.pm view on Meta::CPAN
# mode in Intel syntax.
# Returns 1 if yes.
#
# =cut
#
sub _validate_16bit_addr_parts_intel($$$$$$$) {
my $seg_reg = shift;
my $reg1_sign = shift;
my $reg1 = shift;
my $reg2_sign = shift;
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_16bit_addr_intel($) {
my $elem = shift;
if ( $elem =~ /^(\w+):\s*\[\s*([\+\-]*)\s*(\w+)\s*\]$/o
|| $elem =~ /^\[\s*(\w+)\s*:\s*([\+\-]*)\s*(\w+)\s*\]$/o ) {
lib/Asm/X86.pm view on Meta::CPAN
# mode in AT&T syntax.
# Returns 1 if yes.
#
# =cut
#
sub _is_valid_16bit_addr_reg_att($) {
my $reg = shift;
return 1 if $reg =~ /^%bx$/io || $reg =~ /^%bp$/io
|| $reg =~ /^%si$/io || $reg =~ /^%di$/io;
return 0;
lib/Asm/X86.pm view on Meta::CPAN
# mode in AT&T syntax at the same time because they're of the same type.
# Returns 1 if yes.
#
# =cut
#
sub _is_same_type_16bit_addr_reg_att($$) {
my $reg1 = shift;
my $reg2 = shift;
return 1 if ($reg1 =~ /^%b.$/io && $reg2 =~ /^%b.$/io)
|| ($reg1 =~ /^%.i$/io && $reg2 =~ /^%.i$/io);
lib/Asm/X86.pm view on Meta::CPAN
# mode in AT&T syntax.
# Returns 1 if yes.
#
# =cut
#
sub _validate_16bit_addr_parts_att($$$$$$) {
my $seg_reg = shift;
#my $base_reg_sign = shift; # not allowed in the syntax at all
my $base_reg = shift;
#my $index_reg_sign = shift; # not allowed in the syntax at all
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_16bit_addr_att($) {
my $elem = shift;
if ( $elem =~ /^([%\w]+):\s*\(\s*([%\w]+)\s*\)$/o ) {
return _validate_16bit_addr_parts_att ($1, $2, undef, undef, undef, undef);
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_16bit_addr($) {
my $elem = shift;
return is_valid_16bit_addr_intel ($elem)
| is_valid_16bit_addr_att ($elem);
}
lib/Asm/X86.pm view on Meta::CPAN
# Checks if the given address components give a valid x86 32-bit addressing
# mode in Intel syntax.
# Returns 1 if yes.
#
# =cut
sub _validate_32bit_addr_parts_intel($$$$$$$$) {
my $seg_reg = shift;
my $base_reg_sign = shift;
my $base_reg = shift;
my $index_reg_sign = shift;
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_32bit_addr_intel($) {
my $elem = shift;
# [seg:base+index*scale+disp]
if ( $elem =~ /^\[\s*(\w+)\s*:\s*([\+\-\(\)]*)\s*(\w+)\s*([\+\-\(\)]+)\s*(\w+)\s*\*\s*(\w+)\s*([\+\-\(\)]+)\s*(\w+)\s*(\)*)\s*\]$/o
|| $elem =~ /^(\w+)\s*:\s*\[\s*([\+\-\(\)]*)\s*(\w+)\s*([\+\-\(\)]+)\s*(\w+)\s*\*\s*(\w+)\s*([\+\-\(\)]+)\s*(\w+)\s*(\)*)\s*\]$/o) {
lib/Asm/X86.pm view on Meta::CPAN
# Checks if the given address components give a valid x86 32-bit addressing
# mode in AT&T syntax.
# Returns 1 if yes.
#
# =cut
sub _validate_32bit_addr_parts_att($$$$$$) {
my $seg_reg = shift;
#my $base_reg_sign = shift; # not allowed in the syntax at all
my $base_reg = shift;
#my $index_reg_sign = shift; # not allowed in the syntax at all
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_32bit_addr_att($) {
my $elem = shift;
if ( $elem =~ /^([%\w]+):\s*\(\s*([%\w]+)\s*\)$/o ) {
return _validate_32bit_addr_parts_att ($1, $2, undef, undef, undef, undef);
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_32bit_addr($) {
my $elem = shift;
return is_valid_32bit_addr_intel ($elem)
| is_valid_32bit_addr_att ($elem);
}
lib/Asm/X86.pm view on Meta::CPAN
# mode in Intel syntax.
# Returns 1 if yes.
#
# =cut
#
sub _is_valid_64bit_addr_reg_intel($) {
my $reg = shift;
return 1 if is_reg64_intel($reg) || is_r32_in64_intel($reg) || is_addressable32_intel($reg);
return 0;
}
lib/Asm/X86.pm view on Meta::CPAN
# Checks if the given address components give a valid x86 64-bit addressing
# mode in Intel syntax.
# Returns 1 if yes.
#
# =cut
sub _validate_64bit_addr_parts_intel($$$$$$$$) {
my $seg_reg = shift;
my $base_reg_sign = shift;
my $base_reg = shift;
my $index_reg_sign = shift;
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_64bit_addr_intel($) {
my $elem = shift;
# [seg:base+index*scale+disp]
if ( $elem =~ /^\[\s*(\w+)\s*:\s*([\+\-\(\)]*)\s*(\w+)\s*([\+\-\(\)]+)\s*(\w+)\s*\*\s*(\w+)\s*([\+\-\(\)]+)\s*(\w+)\s*(\)*)\s*\]$/o
|| $elem =~ /^(\w+)\s*:\s*\[\s*([\+\-\(\)]*)\s*(\w+)\s*([\+\-\(\)]+)\s*(\w+)\s*\*\s*(\w+)\s*([\+\-\(\)]+)\s*(\w+)\s*(\)*)\s*\]$/o) {
lib/Asm/X86.pm view on Meta::CPAN
# mode in AT&T syntax.
# Returns 1 if yes.
#
# =cut
#
sub _is_valid_64bit_addr_reg_att($) {
my $reg = shift;
return 1 if is_reg64_att($reg) || is_r32_in64_att($reg) || is_addressable32_att($reg);
return 0;
}
lib/Asm/X86.pm view on Meta::CPAN
# Checks if the given address components give a valid x86 64-bit addressing
# mode in AT&T syntax.
# Returns 1 if yes.
#
# =cut
sub _validate_64bit_addr_parts_att($$$$$$) {
my $seg_reg = shift;
#my $base_reg_sign = shift; # not allowed in the syntax at all
my $base_reg = shift;
#my $index_reg_sign = shift; # not allowed in the syntax at all
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_64bit_addr_att($) {
my $elem = shift;
if ( $elem =~ /^([%\w]+):\s*\(\s*([%\w]+)\s*\)$/o ) {
return _validate_64bit_addr_parts_att ($1, $2, undef, undef, undef, undef);
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_64bit_addr($) {
my $elem = shift;
return is_valid_64bit_addr_intel ($elem)
| is_valid_64bit_addr_att ($elem);
}
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_addr_intel($) {
my $elem = shift;
return is_valid_16bit_addr_intel ($elem)
| is_valid_32bit_addr_intel ($elem)
| is_valid_64bit_addr_intel ($elem);
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_addr_att($) {
my $elem = shift;
return is_valid_16bit_addr_att($elem)
| is_valid_32bit_addr_att($elem)
| is_valid_64bit_addr_att($elem);
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns 1 if yes.
=cut
sub is_valid_addr($) {
my $elem = shift;
return is_valid_addr_intel($elem)
| is_valid_addr_att($elem);
}
lib/Asm/X86.pm view on Meta::CPAN
Tells if the given instruction is suffixed in AT&T syntax.
Returns 1 if yes.
=cut
sub is_att_suffixed_instr($) {
return _is_in_array (shift, \@att_suff_instr);
}
=head2 is_att_suffixed_instr_fpu
lib/Asm/X86.pm view on Meta::CPAN
Tells if the given FPU non-integer instruction is suffixed in AT&T syntax.
Returns 1 if yes
=cut
sub is_att_suffixed_instr_fpu($) {
return _is_in_array (shift, \@att_suff_instr_fpu);
}
=head2 add_att_suffix_instr
lib/Asm/X86.pm view on Meta::CPAN
Creates the AT&T syntax instruction array from the Intel-syntax array.
Returns the new array.
=cut
sub add_att_suffix_instr(@) {
my @result = ();
foreach (@_) {
if ( is_att_suffixed_instr ($_) ) {
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns the resulting string.
=cut
sub conv_att_addr_to_intel($) {
my $par = shift;
$par =~ s/%([a-zA-Z]+)/$1/go;
# seg: disp(base, index, scale)
$par =~ s/(\w+\s*:\s*)([\w\+\-\(\)]+)\s*\(\s*(\w+)\s*,\s*(\w+)\s*,\s*(\d)\s*\)/[$1$3+$5*$4+$2]/o;
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns the resulting string.
=cut
sub conv_intel_addr_to_att($) {
my $par = shift;
my ($z1, $z2, $z3);
# seg: disp(base, index, scale)
# [seg:base+index*scale+disp]
lib/Asm/X86.pm view on Meta::CPAN
# register or a label), returns its value in square brackets (intel-syntax
# memory reference).
#
# =cut
#
sub _change_to_intel_addr_if_applicable($) {
my $par = shift;
# (we mustn't change digits and %st(n), skip also labels)
if ( $par !~ /\$/o && $par !~ /\%/o && $par !~ /_L\d+/o && $par =~ /[a-zA-Z_\.]/o ) {
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns the resulting string.
=cut
sub conv_att_instr_to_intel($) {
my $par = shift;
# process "jmp cs,sth" early so that it doesn't get substituted
my $jmp_2arg = qr/^\s*l?(jmp|call)\s*(\w+)\s*,\s*(\w+)\s*$/io;
lib/Asm/X86.pm view on Meta::CPAN
# If the parameter is not a memory reference or a register, prefixes it with
# a dollar-sign.
#
# =cut
#
sub _remove_size_qualifiers_add_dollar($) {
my $par = shift;
$par =~ s/\s+$//o;
$par =~ s/(t?byte|[dqpftoyz]?word)//io;
$par =~ s/^\s+//o;
lib/Asm/X86.pm view on Meta::CPAN
constants, etc. have been replaced by the real values.
Returns the resulting string.
=cut
sub conv_intel_instr_to_att($) {
my $par = shift;
my ($a1, $a2, $a3, $a4);
$par =~ s/ptr//gi;
Assert-Conditional
view release on metacpan or search on metacpan
lib/Assert/Conditional.pm view on Meta::CPAN
################################################################
# Subs below are grouped by related type. Their documentation is
# in the sub <DATA> pod.
sub assert_list_context()
:Assert( qw[context] )
{
my $wantarray = his_context;
$wantarray || botch "wanted to be called in list context";
}
sub assert_nonlist_context()
:Assert( qw[context] )
{
my $wantarray = his_context;
!$wantarray || botch "wanted to be called in nonlist context";
}
sub assert_scalar_context()
:Assert( qw[context] )
{
my $wantarray = his_context;
defined($wantarray) && !$wantarray
|| botch "wanted to be called in scalar context";
}
sub assert_void_context()
:Assert( qw[context] )
{
my $wantarray = his_context;
!defined($wantarray) || botch "wanted to be called in void context";
}
sub assert_nonvoid_context()
:Assert( qw[context] )
{
my $wantarray = his_context;
defined($wantarray) || botch "wanted to be called in nonvoid context";
}
sub assert_true($)
:Assert( qw[scalar boolean] )
{
my($arg) = @_;
$arg || botch "expected true argument";
}
sub assert_false($)
:Assert( qw[scalar boolean] )
{
my($arg) = @_;
$arg && botch "expected true argument";
}
sub assert_defined($)
:Assert( qw[scalar] )
{
my($value) = @_;
defined($value) || botch "expected defined value as argument";
}
sub assert_undefined($)
:Assert( qw[scalar] )
{
my($scalar) = @_;
defined($scalar) && botch "expected undefined argument";
}
sub assert_defined_variable(\$)
:Assert( qw[scalar] )
{
&assert_scalarref;
my($sref) = @_;
defined($$sref) || botch "expected defined scalar variable as argument";
}
sub assert_defined_value($)
:Assert( qw[scalar] )
{
my($value) = @_;
defined($value) || botch "expected defined value as argument";
}
sub assert_is($$)
:Assert( qw[string] )
{
my($this, $that) = @_;
assert_defined($_) for $this, $that;
assert_nonref($_) for $this, $that;
$this eq $that || botch "string '$this' should be '$that'";
}
sub assert_isnt($$)
:Assert( qw[string] )
{
my($this, $that) = @_;
assert_defined($_) for $this, $that;
assert_nonref($_) for $this, $that;
$this ne $that || botch "string '$this' should not be '$that'";
}
sub assert_numeric($)
:Assert( qw[number] )
{
&assert_defined;
&assert_nonref;
my($n) = @_;
looks_like_number($n) || botch "'$n' doesn't look like a number";
}
sub assert_nonnumeric($)
:Assert( qw[number] )
{
&assert_nonref;
my($n) = @_;
!looks_like_number($n) || botch "'$n' looks like a number";
}
sub assert_positive($)
:Assert( qw[number] )
{
&assert_numeric;
my($n) = @_;
$n > 0 || botch "$n should be positive";
}
sub assert_nonpositive($)
:Assert( qw[number] )
{
&assert_numeric;
my($n) = @_;
$n <= 0 || botch "$n should not be positive";
}
sub assert_negative($)
:Assert( qw[number] )
{
&assert_numeric;
my($n) = @_;
$n < 0 || botch "$n should be negative";
}
sub assert_nonnegative($)
:Assert( qw[number] )
{
&assert_numeric;
my($n) = @_;
$n >= 0 || botch "$n should not be negative";
}
sub assert_zero($)
:Assert( qw[number] )
{
&assert_numeric;
my($n) = @_;
$n == 0 || botch "$n should be zero";
}
sub assert_nonzero($)
:Assert( qw[number] )
{
&assert_numeric;
my($n) = @_;
$n != 0 || botch "$n should not be zero";
}
sub assert_integer($)
:Assert( qw[number] )
{
&assert_numeric;
my($int) = @_;
$int == int($int) || botch "expected integer, not $int";
}
sub assert_fractional($)
:Assert( qw[number] )
{
&assert_numeric;
my($float) = @_;
$float != int($float) || botch "expected fractional part, not $float";
}
sub assert_signed_number($)
:Assert( qw[number] )
{
&assert_numeric;
my($n) = @_;
$n =~ /^ [-+] /x || botch "expected signed number, not $n";
}
sub assert_natural_number($)
:Assert( qw[number] )
{
&assert_positive_integer;
my($int) = @_;
}
sub assert_whole_number($)
:Assert( qw[number] )
{
&assert_nonnegative_integer;
my($int) = @_;
}
sub assert_positive_integer($)
:Assert( qw[number] )
{
&assert_integer;
&assert_positive;
}
sub assert_nonpositive_integer($)
:Assert( qw[number] )
{
&assert_integer;
&assert_nonpositive;
}
sub assert_negative_integer($)
:Assert( qw[number] )
{
&assert_integer;
&assert_negative;
}
sub assert_nonnegative_integer($)
:Assert( qw[number] )
{
&assert_integer;
&assert_nonnegative;
}
sub assert_hex_number($)
:Assert( qw[regex number] )
{
local($_) = @_;
/^ (?:0x)? \p{ahex}+ \z/ix || botch "expected only ASCII hex digits in string '$_'";
}
sub assert_box_number($)
:Assert( qw[number] )
{
local($_) = @_;
&assert_defined;
/^ (?: 0b ) [0-1]+ \z /x ||
/^ (?: 0o | 0)? [0-7]+ \z /x ||
/^ (?: 0x ) [0-9a-fA-F]+ \z /x
|| botch "I wouldn't feed '$_' to oct() if I were you";
}
sub assert_even_number($)
:Assert( qw[number] )
{
&assert_integer;
my($n) = @_;
$n % 2 == 0 || botch "$n should be even";
}
sub assert_odd_number($)
:Assert( qw[number] )
{
&assert_integer;
my($n) = @_;
$n % 2 == 1 || botch "$n should be odd";
}
sub assert_in_numeric_range($$$)
:Assert( qw[number] )
{
assert_numeric($_) for my($n, $low, $high) = @_;
$n >= $low && $n <= $high || botch "expected $low <= $n <= $high";
}
sub assert_empty($)
:Assert( qw[string] )
{
&assert_defined;
&assert_nonref;
my($string) = @_;
length($string) == 0 || botch "expected zero-length string";
}
sub assert_nonempty($)
:Assert( qw[string] )
{
&assert_defined;
&assert_nonref;
my($string) = @_;
length($string) != 0 || botch "expected non-zero-length string";
}
sub assert_blank($)
:Assert( qw[string regex] )
{
&assert_defined;
&assert_nonref;
my($string) = @_;
$string =~ /^ \p{whitespace}* \z/x || botch "found non-whitespace in string '$string'"
}
sub assert_nonblank($)
:Assert( qw[string regex] )
{
&assert_defined;
&assert_nonref;
my($string) = @_;
lib/Assert/Conditional.pm view on Meta::CPAN
( (?! \R ) \X )+
\R ?
\z
}x;
sub assert_single_line($)
:Assert( qw[string regex] )
{
&assert_nonempty;
my($string) = @_;
$string =~ $_single_line_rx || botch "expected at most a single linebreak at the end";
}
sub assert_multi_line($)
:Assert( qw[string regex] )
{
&assert_nonempty;
my($string) = @_;
$string !~ $_single_line_rx || botch "expected more than one linebreak";
}
sub assert_single_paragraph($)
:Assert( qw[string regex] )
{
&assert_nonempty;
my($string) = @_;
$string =~ / \A ( (?! \R ) \X )+ \R* \z /x
|| botch "expected at most a single linebreak at the end";
}
sub assert_bytes($)
:Assert( qw[string] )
{
local($_) = @_;
/^ [\x00-\xFF] + \z/x || botch "unexpected wide characters in byte string";
}
sub assert_nonbytes($)
:Assert( qw[string] )
{
&assert_wide_characters;
}
sub assert_wide_characters($)
:Assert( qw[string] )
{
local($_) = @_;
/[^\x00-\xFF]/x || botch "expected some wide characters in string";
}
sub assert_nonascii($)
:Assert( qw[string regex] )
{
local($_) = @_;
/\P{ascii}/x || botch "expected non-ASCII in string";
}
sub assert_ascii($)
:Assert( qw[string regex] )
{
local($_) = @_;
/^ \p{ASCII} + \z/x || botch "expected only ASCII in string";
}
sub assert_alphabetic($)
:Assert( qw[string regex] )
{
local($_) = @_;
/^ \p{alphabetic} + \z/x || botch "expected only alphabetics in string";
}
sub assert_nonalphabetic($)
:Assert( qw[string regex] )
{
local($_) = @_;
/^ \P{alphabetic} + \z/x || botch "expected only non-alphabetics in string";
}
sub assert_alnum($)
:Assert( qw[regex] )
{
local($_) = @_;
/^ \p{alnum} + \z/x || botch "expected only alphanumerics in string";
}
sub assert_digits($)
:Assert( qw[regex number] )
{
local($_) = @_;
/^ [0-9] + \z/x || botch "expected only ASCII digits in string";
}
sub assert_uppercased($)
:Assert( qw[case regex] )
{
local($_) = @_;
($] >= 5.014
? ! /\p{Changes_When_Uppercased}/
: $_ eq uc ) || botch "changes case when uppercased";
}
sub assert_lowercased($)
:Assert( qw[case regex] )
{
local($_) = @_;
($] >= 5.014
? ! /\p{Changes_When_Lowercased}/
: $_ eq lc ) || botch "changes case when lowercased";
}
sub assert_unicode_ident($)
:Assert( qw[regex] )
{
local($_) = @_;
/^ \p{XID_Start} \p{XID_Continue}* \z/x
|| botch "invalid identifier $_";
lib/Assert/Conditional.pm view on Meta::CPAN
(?: $perl_simple_ident_rx
| (?: :: | ' )
) +
}x;
sub assert_simple_perl_ident($)
:Assert( qw[regex ident] )
{
local($_) = @_;
/^ $perl_simple_ident_rx \z/x
|| botch "invalid simple perl identifier $_";
}
sub assert_full_perl_ident($)
:Assert( qw[regex ident] )
{
local($_) = @_;
/^ $perl_qualified_ident_rx \z/x
|| botch "invalid qualified perl identifier $_";
}
sub assert_qualified_ident($)
:Assert( qw[regex ident] )
{
&assert_full_perl_ident;
local($_) = @_;
/(?: ' | :: ) /x || botch "no package separators in $_";
}
sub assert_ascii_ident($)
:Assert( qw[regex ident] )
{
local($_) = @_;
/^ (?= \p{ASCII}+ \z) (?! \d) \w+ \z/x
|| botch q(expected only ASCII \\w characters in string);
}
sub assert_regex($)
:Assert( qw[regex] )
{
my($pattern) = @_;
assert_isa($pattern, "Regexp");
}
sub assert_like($$)
:Assert( qw[regex] )
{
my($string, $pattern) = @_;
assert_defined($string);
assert_nonref($string);
assert_regex($pattern);
$string =~ $pattern || botch "'$string' did not match $pattern";
}
sub assert_unlike($$)
:Assert( qw[regex] )
{
my($string, $pattern) = @_;
assert_defined($string);
assert_nonref($string);
assert_regex($pattern);
$string !~ $pattern || botch "'$string' should not match $pattern";
}
sub assert_latin1($)
:Assert( qw[string unicode] )
{
&assert_bytes;
}
sub assert_latinish($)
:Assert( qw[unicode] )
{
local($_) = @_;
/^[\p{Latin}\p{Common}\p{Inherited}]+/
|| botch "expected only Latinish characters in string";
}
sub assert_astral($)
:Assert( qw[unicode] )
{
local($_) = @_;
no warnings "utf8"; # early versions of perl complain of illegal for interchange on FFFF
/[^\x00-\x{FFFF}]/x || botch "expected non-BMP characters in string";
}
sub assert_nonastral($)
:Assert( qw[unicode] )
{
local($_) = @_;
no warnings "utf8"; # early versions of perl complain of illegal for interchange on FFFF
/^ [\x00-\x{FFFF}] * \z/x || botch "unexpected non-BMP characters in string";
}
sub assert_bmp($)
:Assert( qw[unicode] )
{
&assert_nonastral;
}
sub assert_nfc($)
:Assert( qw[unicode] )
{
my($str) = @_;
checkNFC($str) // $str eq NFC($str)
|| botch "string not in NFC form";
}
sub assert_nfkc($)
:Assert( qw[unicode] )
{
my($str) = @_;
checkNFKC($str) // $str eq NFKC($str)
|| botch "string not in NFKC form";
}
sub assert_nfd($)
:Assert( qw[unicode] )
{
my($str) = @_;
checkNFD($str) || botch "string not in NFD form";
}
sub assert_nfkd($)
:Assert( qw[unicode] )
{
my($str) = @_;
checkNFKD($str) || botch "string not in NFKD form";
}
sub assert_eq($$)
:Assert( qw[string unicode] )
{
my($this, $that) = @_;
NFC($this) eq NFC($that) || botch "'$this' and '$that' are not equivalent Unicode strings";
}
sub assert_eq_letters($$)
:Assert( qw[string unicode] )
{
my($this, $that) = @_;
UCA1($this) eq UCA1($that) || botch "'$this' and '$that' do not equivalent letters"
}
sub assert_in_list($@)
:Assert( qw[list] )
{
my($needle, @haystack) = @_;
#assert_nonref($needle);
my $undef_needle = !defined($needle);
lib/Assert/Conditional.pm view on Meta::CPAN
}
$needle = "undef" unless defined $needle;
botch "couldn't find $needle in " . join(", " => map { defined() ? $_ : "undef" } @haystack);
}
sub assert_not_in_list($@)
:Assert( qw[list] )
{
my($needle, @haystack) = @_;
my $found = 0;
for my $straw (@haystack) {
lib/Assert/Conditional.pm view on Meta::CPAN
return unless $found;
$needle = "undef" unless defined $needle;
botch "found $needle in forbidden list";
}
sub assert_list_nonempty( @ )
:Assert( qw[list array] )
{
@_ || botch "list is empty";
}
sub assert_array_nonempty( \@ )
:Assert( qw[array] )
{
&assert_arrayref_nonempty;
}
sub assert_arrayref_nonempty( $ )
:Assert( qw[array] )
{
&assert_array_length;
my($aref) = @_;
assert_arrayref($aref);
my $count = @$aref;
$count > 0 || botch("array is empty");
}
sub assert_array_length( \@ ;$ )
:Assert( qw[array] )
{
if (@_ == 1) {
assert_array_length_min(@{$_[0]} => 1);
return;
lib/Assert/Conditional.pm view on Meta::CPAN
assert_whole_number($want);
my $have = @$aref;
$have == $want || botch_array_length($have, $want);
}
sub assert_array_length_min( \@ $ )
:Assert( qw[array] )
{
my($aref, $want) = @_;
assert_arrayref($aref);
assert_whole_number($want);
my $have = @$aref;
$have >= $want || botch_array_length($have, "$want or more");
}
sub assert_array_length_max( \@ $ )
:Assert( qw[array] )
{
my($aref, $want) = @_;
assert_arrayref($aref);
assert_whole_number($want);
my $have = @$aref;
$have <= $want || botch_array_length($have, "$want or fewer");
}
sub assert_array_length_minmax( \@ $$)
:Assert( qw[array] )
{
my($aref, $low, $high) = @_;
my $have = @$aref;
assert_whole_number($_) for $low, $high;
$have >= $low && $have <= $high
|| botch_array_length($have, "between $low and $high");
}
sub assert_argc(;$)
:Assert( qw[argc] )
{
unless (@_) {
his_args || botch_argc(0, "at least 1");
return;
lib/Assert/Conditional.pm view on Meta::CPAN
my($want) = @_;
my $have = his_args;
$have == $want || botch_argc($have, $want);
}
sub assert_argc_min($)
:Assert( qw[argc] )
{
&assert_whole_number;
my($want) = @_;
my $have = his_args;
$have >= $want || botch_argc($have, "$want or more");
}
sub assert_argc_max($)
:Assert( qw[argc] )
{
&assert_whole_number;
my($want) = @_;
my $have = his_args;
$have <= $want || botch_argc($have, "$want or fewer");
}
sub assert_argc_minmax($$)
:Assert( qw[argc] )
{
assert_whole_number($_) for my($low, $high) = @_;
my $have = his_args;
$have >= $low && $have <= $high
|| botch_argc($have, "between $low and $high");
}
sub assert_hash_nonempty(\%)
:Assert( qw[hash] )
{
&assert_hashref_nonempty;
}
sub assert_hashref_nonempty($)
:Assert( qw[hash] )
{
&assert_hashref;
my($href) = @_;
%$href || botch "hash is empty";
}
sub assert_hash_keys(\% @)
:Assert( qw[hash] )
{
&assert_hashref_keys;
}
sub assert_hash_keys_required(\% @)
:Assert( qw[hash] )
{
&assert_hashref_keys_required;
}
sub assert_hash_keys_allowed(\% @)
:Assert( qw[hash] )
{
&assert_hashref_keys_allowed;
}
sub assert_hash_keys_required_and_allowed(\% $ $)
:Assert( qw[hash] )
{
&assert_hashref_keys_required_and_allowed;
}
sub assert_hash_keys_allowed_and_required(\% $ $)
:Assert( qw[hash] )
{
&assert_hashref_keys_allowed_and_required;
}
sub assert_hashref_keys($@)
:Assert( qw[hash] )
{
&assert_hashref_keys_required;
}
sub assert_hashref_keys_required($@)
:Assert( qw[hash] )
{
my($hashref, @keylist) = @_;
assert_min_keys($hashref, @keylist);
}
sub assert_hashref_keys_allowed($@)
:Assert( qw[hash] )
{
my($hashref, @keylist) = @_;
assert_max_keys($hashref, @keylist);
}
sub _promote_to_typeref($$) {
my(undef, $type) = @_;
&assert_anyref;
$_[0] = ${ $_[0] } if (reftype($_[0]) // "") =~ /^ (?: SCALAR | REF ) \z/x;
assert_reftype($type, $_[0]);
}
sub _promote_to_hashref ($) { _promote_to_typeref($_[0], "HASH") }
sub _promote_to_arrayref($) { _promote_to_typeref($_[0], "ARRAY") }
sub assert_min_keys( \[%$] @ )
:Assert( qw[hash] )
{
my($hashref, @keylist) = @_;
_promote_to_hashref($hashref);
@keylist || botch "no min keys given";
lib/Assert/Conditional.pm view on Meta::CPAN
. " missing from hash";
botch $message;
}
sub assert_max_keys( \[%$] @ )
:Assert( qw[hash] )
{
my($hashref, @keylist) = @_;
_promote_to_hashref($hashref);
my %allowed = map { $_ => 1 } @keylist;
lib/Assert/Conditional.pm view on Meta::CPAN
. " forbidden in hash";
botch $message;
}
sub assert_minmax_keys( \[%$] \[@$] \[@$] )
:Assert( qw[hash] )
{
my($hashref, $minkeys, $maxkeys) = @_;
_promote_to_hashref($hashref);
_promote_to_arrayref($minkeys);
lib/Assert/Conditional.pm view on Meta::CPAN
my $message = commify_and grep { length } $missing_msg, $forbidden_msg;
botch $message;
}
sub assert_keys( \[%$] @ )
:Assert( qw[hash] )
{
my($hashref, @keylist) = @_;
_promote_to_hashref($hashref);
assert_minmax_keys($hashref, @keylist, @keylist);
}
sub assert_hashref_keys_required_and_allowed($$$)
:Assert( qw[hash] )
{
my($hashref, $required, $allowed) = @_;
assert_minmax_keys($hashref, $required, $allowed);
}
sub assert_hashref_keys_allowed_and_required($$$)
:Assert( qw[hash] )
{
my($hashref, $allowed, $required) = @_;
assert_minmax_keys($hashref, $required, $allowed);
}
lib/Assert/Conditional.pm view on Meta::CPAN
END_OF_LOCK_STUFF
}
}
sub assert_anyref($)
:Assert( qw[ref] )
{
my($arg) = @_;
ref($arg) || botch "expected reference argument";
}
sub assert_nonref($)
:Assert( qw[ref] )
{
my($arg) = @_;
!ref($arg) || botch "expected nonreference argument";
}
sub assert_reftype($$)
:Assert( qw[object ref] )
{
my($want_type, $arg) = @_;
my $have_type = reftype($arg) // "non-reference";
$have_type eq $want_type || botch "expected reftype of $want_type not $have_type";
}
sub assert_globref($)
:Assert( qw[glob ref] )
{
my($arg) = @_;
assert_reftype(GLOB => $arg);
}
sub assert_ioref($)
:Assert( qw[io ref] )
{
my($arg) = @_;
assert_reftype(IO => $arg);
}
sub assert_coderef($)
:Assert( qw[code ref] )
{
my($arg) = @_;
assert_reftype(CODE => $arg);
}
sub assert_hashref($)
:Assert( qw[hash ref] )
{
my($arg) = @_;
assert_reftype(HASH => $arg);
}
sub assert_arrayref($)
:Assert( qw[array ref] )
{
my($arg) = @_;
assert_reftype(ARRAY => $arg);
}
sub assert_refref($)
:Assert( qw[ref] )
{
my($arg) = @_;
assert_reftype(REF => $arg);
}
sub assert_scalarref($)
:Assert( qw[scalar ref] )
{
my($arg) = @_;
assert_reftype(SCALAR => $arg);
}
sub assert_unblessed_ref($)
:Assert( qw[ref object] )
{
&assert_anyref;
&assert_nonobject;
}
sub assert_method()
:Assert( qw[object] )
{
my $argc = his_args;
$argc >= 1 || botch "invocant missing from method invoked as subroutine";
}
sub assert_object_method()
:Assert( qw[object] )
{
my $argc = his_args;
$argc >= 1 || botch "no invocant found";
my($self) = his_args;
blessed($self) || botch "object method invoked as class method";
}
sub assert_class_method()
:Assert( qw[object] )
{
my $argc = his_args;
$argc >= 1 || botch "no invocant found";
my($class) = his_args;
!blessed($class) || botch "class method invoked as object method";
}
# This one is a no-op!
sub assert_public_method()
:Assert( qw[object] )
{
my $argc = his_args;
$argc >= 1 || botch "invocant missing from public method invoked as subroutine";
}
lib/Assert/Conditional.pm view on Meta::CPAN
Class::MOP::Method::Wrapped
Moose::Meta::Method::Augmented
);
# And this one isn't *all* that hard... relatively speaking.
sub assert_private_method()
:Assert( qw[object] )
{
my $argc = his_args;
$argc >= 1 || botch "invocant missing from private method invoked as subroutine";
lib/Assert/Conditional.pm view on Meta::CPAN
}
# But this one? This one is RIDICULOUS. O Moose how we hates you
# foreverz for ruining perl's simple inheritance model and its export
# model and its import model and its package model till the end of time!
sub assert_protected_method()
:Assert( qw[object] )
{
my $argc = his_args;
$argc >= 1 || botch "invocant missing from protected method invoked as subroutine";
lib/Assert/Conditional.pm view on Meta::CPAN
line => $from[CALLER_LINE]
);
}
sub assert_known_package($)
:Assert( qw[object ident] )
{
&assert_nonempty;
my($arg) = @_;
my $stash = do { no strict "refs"; \%{ $arg . "::" } };
no overloading;
%$stash || botch "unknown package $arg";
}
sub assert_object($)
:Assert( qw[object] )
{
no overloading;
&assert_anyref;
my($arg) = @_;
blessed($arg) || botch "expected blessed referent not $arg";
}
sub assert_nonobject($)
:Assert( qw[object] )
{
no overloading;
my($arg) = @_;
!blessed($arg) || botch "expected unblessed referent not $arg";
}
sub _get_invocant_type($) {
my($invocant) = @_;
my $type;
if (blessed $invocant) {
$type = "object";
} else {
$type = "package";
}
return $type;
}
sub assert_can($@)
:Assert( qw[object] )
{
no overloading;
my($invocant, @methods) = @_;
@methods || botch "need one or more methods to check against";
lib/Assert/Conditional.pm view on Meta::CPAN
. " on $type $invocant";
botch $message;
}
sub assert_cant($@)
:Assert( qw[object] )
{
no overloading;
my($invocant, @methods) = @_;
@methods || botch "need one or more methods to check against";
lib/Assert/Conditional.pm view on Meta::CPAN
. " on $type $invocant";
botch $message;
}
sub assert_object_can($@)
:Assert( qw[object] )
{
my($instance, @methods) = @_;
assert_object($instance);
assert_can($instance, @methods);
}
sub assert_object_cant($@)
:Assert( qw[object] )
{
my($instance, @methods) = @_;
assert_object($instance);
assert_cant($instance, @methods);
}
sub assert_class_can($@)
:Assert( qw[object] )
{
my($class, @methods) = @_;
assert_known_package($class);
assert_can($class, @methods);
}
sub assert_class_cant($@)
:Assert( qw[object] )
{
my($class, @methods) = @_;
assert_known_package($class);
assert_cant($class, @methods);
}
sub assert_isa($@)
:Assert( qw[object] )
{
my($subclass, @superclasses) = @_;
@superclasses || botch "needs one or more superclasses to check against";
my $type = _get_invocant_type $subclass;
my @ainta = grep { !$subclass->isa($_) } @superclasses;
!@ainta || botch "your $subclass $type should be a subclass of " . commify_and(uca_sort @ainta);
}
sub assert_ainta($@)
:Assert( qw[object] )
{
no overloading;
my($subclass, @superclasses) = @_;
lib/Assert/Conditional.pm view on Meta::CPAN
my $type = _get_invocant_type $subclass;
my @isa = grep { $subclass->isa($_) } @superclasses;
!@isa || botch "your $subclass $type should not be a subclass of " . commify_or(uca_sort @isa);
}
sub assert_object_isa($@)
:Assert( qw[object] )
{
my($instance, @superclasses) = @_;
assert_object($instance);
assert_isa($instance, @superclasses);
}
sub assert_object_ainta($@)
:Assert( qw[object] )
{
my($instance, @superclasses) = @_;
assert_object($instance);
assert_ainta($instance, @superclasses);
}
sub assert_class_isa($@)
:Assert( qw[object] )
{
my($class, @superclasses) = @_;
assert_known_package($class);
assert_isa($class, @superclasses);
}
sub assert_class_ainta($@)
:Assert( qw[object] )
{
my($class, @superclasses) = @_;
assert_known_package($class);
assert_ainta($class, @superclasses);
}
sub assert_does($@)
:Assert( qw[object] )
{
no overloading;
my($invocant, @roles) = @_;
@roles || botch "needs one or more roles to check against";
lib/Assert/Conditional.pm view on Meta::CPAN
!@doesnt || botch "your $type $invocant does not have role"
. (@doesnt > 1 && "s") . " "
. commify_or(uca_sort @doesnt);
}
sub assert_doesnt($@)
:Assert( qw[object] )
{
no overloading;
my($invocant, @roles) = @_;
@roles || botch "needs one or more roles to check against";
lib/Assert/Conditional.pm view on Meta::CPAN
!@does || botch "your $type $invocant does not have role"
. (@does > 1 && "s") . " "
. commify_or(uca_sort @does);
}
sub assert_object_overloads($@)
:Assert( qw[object overload] )
{
no overloading;
&assert_object;
my($object, @operators) = @_;
lib/Assert/Conditional.pm view on Meta::CPAN
!@missing || botch "your $object does not overload the operator"
. (@missing > 1 && "s") . " "
. quotify_or(@missing);
}
sub assert_object_stringifies($)
:Assert( qw[object overload] )
{
my($object) = @_;
assert_object_overloads $object, q{""};
}
sub assert_object_nummifies($)
:Assert( qw[object overload] )
{
my($object) = @_;
assert_object_overloads $object, q{0+};
}
sub assert_object_boolifies($)
:Assert( qw[object overload] )
{
my($object) = @_;
assert_object_overloads $object, q{bool};
}
lib/Assert/Conditional.pm view on Meta::CPAN
}
} # scope for no overloading
# Common subroutine for the two happy/unhappy code tests.
sub _run_code_test($$) {
my($code, $joy) = @_;
assert_coderef($code);
return if !!&$code() == !!$joy;
botch sprintf "%s assertion %s is sadly %s",
$joy ? "happy" : "unhappy",
subname_or_code($code),
$joy ? "false" : "true";
}
sub assert_happy_code(&)
:Assert( qw[boolean code] )
{
my($cref) = @_;
_run_code_test($cref => 1);
}
sub assert_unhappy_code(&)
:Assert( qw[boolean code] )
{
my($cref) = @_;
_run_code_test($cref => 0);
}
sub assert_open_handle($)
:Assert( qw[io file] )
{
my($arg) = @_;
assert_defined($arg);
defined(openhandle($arg)) || botch "handle $arg is not an open handle";
}
sub assert_regular_file($)
:Assert( qw[file] )
{
my($arg) = @_;
assert_defined($arg);
-f $arg || botch "appears that $arg is not a plainfile"
. " nor a symlink to a plainfile";
}
sub assert_text_file($)
:Assert( qw[file] )
{
&assert_regular_file;
my($arg) = @_;
-T $arg || botch "appears that $arg does not contain text";
}
sub assert_directory($)
:Assert( qw[file] )
{
my($arg) = @_;
-d $arg || botch "appears that $arg is not a directory"
. " nor a symlink to a directory";
}
sub _WIFCORED(;$) {
my($wstat) = @_ ? $_[0] : $?;
# non-standard but nearly ubiquitous; too hard to fish from real sys/wait.h
return WIFSIGNALED($wstat) && !!($wstat & 128);
}
sub _coredump_message(;$) {
my($wstat) = @_ ? $_[0] : $?;
return _WIFCORED($wstat) && " (core dumped)";
}
sub _signum_message($) {
my($number) = @_;
my $name = sig_num2longname($number);
return "$name(#$number)";
}
sub assert_legal_exit_status(;$)
:Assert( qw[process] )
{
my($wstat) = @_ ? $_[0] : $?;
assert_whole_number($wstat);
$wstat < 2**16 || botch "exit value $wstat over 16 bits";
}
sub assert_signalled(;$)
:Assert( qw[process] )
{
&assert_legal_exit_status;
my($wstat) = @_ ? $_[0] : $?;
WIFSIGNALED($wstat) || botch "exit value $wstat indicates no signal";
}
sub assert_unsignalled(;$)
:Assert( qw[process] )
{
&assert_legal_exit_status;
my($wstat) = @_ ? $_[0] : $?;
WIFEXITED($wstat) && return;
lib/Assert/Conditional.pm view on Meta::CPAN
my $sigmsg = _signum_message($signo);
my $cored = _coredump_message($wstat);
botch "exit value $wstat indicates process died from signal $sigmsg$cored";
}
sub assert_dumped_core(;$)
:Assert( qw[process] )
{
&assert_signalled;
my($wstat) = @_ ? $_[0] : $?;
my $signo = WTERMSIG($wstat);
my $sigmsg = _signum_message($signo);
_WIFCORED($wstat) || botch "exit value $wstat indicates signal $sigmsg but no core dump";
}
sub assert_no_coredump(;$)
:Assert( qw[process] )
{
my($wstat) = @_ ? $_[0] : $?;
my $cored = $wstat & 128; # not standard; too hard to fish from real sys/wait.h
return unless _WIFCORED($wstat);
lib/Assert/Conditional.pm view on Meta::CPAN
my $signo = WTERMSIG($wstat);
my $sigmsg = _signum_message($signo);
botch "exit value $wstat shows process died of a $sigmsg and dumped core";
}
sub assert_exited(;$)
:Assert( qw[process] )
{
&assert_legal_exit_status;
my($wstat) = @_ ? $_[0] : $?;
return if WIFEXITED($wstat);
lib/Assert/Conditional.pm view on Meta::CPAN
my $sigmsg = _signum_message($signo);
my $cored = _coredump_message($wstat);
botch "exit value $wstat shows process did not exit but rather died of $sigmsg$cored";
}
sub assert_happy_exit(;$)
:Assert( qw[process] )
{
&assert_exited;
my($wstat) = @_ ? $_[0] : $?;
my $exit = WEXITSTATUS($wstat);
$exit == 0 || botch "exit status $exit is not a happy exit";
}
sub assert_sad_exit(;$)
:Assert( qw[process] )
{
&assert_exited;
my($wstat) = @_ ? $_[0] : $?;
my $exit = WEXITSTATUS($wstat);
Assert-Refute
view release on metacpan or search on metacpan
lib/Assert/Refute.pm view on Meta::CPAN
It will stay available (with a warning) until as least 0.15.
=cut
sub try_refute(&;@) { ## no critic # need prototype
my ( $block, @arg ) = @_;
# Should a missing config even happen? Ok, play defensively...
my $conf = $CALLER_CONF{+caller};
if( !$conf ) {
lib/Assert/Refute.pm view on Meta::CPAN
it's up to the user to call return.
This MAY change in the future.
=cut
sub plan(@) { ## no critic
current_contract->plan( @_ );
};
=head2 refute( $reason, $message )
lib/Assert/Refute.pm view on Meta::CPAN
$array_of_foo->apply( $valid_user, \@user_list );
=cut
sub subcontract($$@) { ## no critic
current_contract()->subcontract( @_ );
};
=head2 contract_is
Asset-Pack
view release on metacpan or search on metacpan
t/internals/pack_metadata.t view on Meta::CPAN
return $stash_contents;
}
our $nfails;
sub my_subtest($$) {
note "(fake)Subtest: $_[0]";
local $nfails = 0;
$_[1]->();
note "End (fake)subtest: $_[0]";
return is( $nfails, 0, "No failures in (fake)subtest $_[0]" );
Asterisk-Store-Queue
view release on metacpan or search on metacpan
lib/Asterisk/Store/Queue.pm view on Meta::CPAN
usage:
$queueobj->add_member($memberobj)
=cut
sub add_member() {
my $self = shift;
my $internalobj = shift;
if ( UNIVERSAL::isa $internalobj, 'Asterisk::Store::Queue::Member' ) {
push @{$self->{'members'}}, $internalobj;
} else {
( run in 0.551 second using v1.01-cache-2.11-cpan-65fba6d93b7 )