view release on metacpan or search on metacpan
lib/Class/Mix.pm view on Meta::CPAN
order to be returned by future invocations. If you want to modify your
dynamically-generated `anonymous' classes, use C<genpkg> (below).
=cut
sub genpkg(;$);
my %mixtures;
sub mix_class(@) {
my @parents;
my %options;
foreach(@_) {
if(is_string($_)) {
push @parents, $_;
lib/Class/Mix.pm view on Meta::CPAN
is not supplied, the caller is not expressing any preference.
=cut
my $n = 0;
sub genpkg(;$) {
my($prefix) = @_;
$prefix = "Class::Mix::" unless defined $prefix;
croak "`$prefix' is not a valid module name prefix"
unless $prefix =~ /\A$prefix_rx\z/o;
no strict "refs";
view release on metacpan or search on metacpan
lib/Class/Modular.pm view on Meta::CPAN
$self->is_loaded($module) || $self->load($module);
}
=cut
sub load($$;$) {
my ($self,$subclass,$options) = @_;
$options ||= {};
# check to see if the subclass has already been loaded.
lib/Class/Modular.pm view on Meta::CPAN
Returns 1 if the subclass has been loaded, 0 otherwise.
=cut
sub is_loaded($$){
my ($self,$subclass) = @_;
# An entry will exist in the _subclasses hashref only if
return 1 if exists $self->{$cm}{_subclasses}{$subclass}
and defined $self->{$cm}{_subclasses}{$subclass};
lib/Class/Modular.pm view on Meta::CPAN
Methods that have previously been overridden by override are _NOT_
overridden again. This may need to be adjusted in load.
=cut
sub _addmethods($@) {
my ($self,$subclass,@methods) = @_;
# stick the method into the table
# DLA: Make with the munchies!
view release on metacpan or search on metacpan
}
return undef;
};
sub walk_width(&$;@) {
&$walk_raw( 1, @_ );
}
sub walk_depth(&$;@) {
&$walk_raw( 0, @_ );
}
sub walk(&$;@) {
confess( "Class::Multi::walk is deprecated. Use walk_width or walk_depth instead.\n" );
&$walk_raw( 0, @_ );
}
sub walk_width_up(&$;@) {
my ( $callout, $derived, @avoid ) = @_;
my @classes;
walk_width { push @classes, $_; 0 } $derived, @avoid;
The calling class is inferred via C<caller()>.
=cut
sub other($$) {
my ( $this, $name ) = @_;
my ( $origin, $caller );
# a valid class or instance must be supplied
$origin = ref( $this ) || $this or return;
Identical to C<other>, except the package name is returned instead of
the desired method's code reference.
=cut
sub otherpkg($$) {
my ( $this, $name ) = @_;
my ( $origin, $caller );
# a valid class or instance must be supplied
$origin = ref( $this ) || $this or return;
Equivalent to C<< &{other( $this, METHOD )}( $this, @myargs ); >>.
=cut
sub otherrun($$) {
my $this = shift;
my $name = shift;
my ( $origin, $caller, $func );
# a valid class or instance must be supplied
view release on metacpan or search on metacpan
lib/Class/Multimethods/Pure.pm view on Meta::CPAN
else {
croak "Unknown command: $cmd";
}
}
sub all(@) {
Class::Multimethods::Pure::Type::Conjunction->new(
Class::Multimethods::Pure::Type->promote(@_)
);
}
sub any(@) {
Class::Multimethods::Pure::Type::Disjunction->new(
Class::Multimethods::Pure::Type->promote(@_)
);
}
sub none(@) {
Class::Multimethods::Pure::Type::Injunction->new(
Class::Multimethods::Pure::Type->promote(@_)
);
}
sub Any() {
Class::Multimethods::Pure::Type::Any->new;
}
sub subtype($$) {
Class::Multimethods::Pure::Type::Subtype->new(
Class::Multimethods::Pure::Type->promote($_[0]), $_[1]
);
}
view release on metacpan or search on metacpan
lib/Class/OWL.pm view on Meta::CPAN
},
ExpandQNames => 1,
);
my $DEBUG = 0;
sub debug($) { return unless $DEBUG; print STDERR @_, "\n" }
sub import {
my $class = shift;
my %opt = @_;
lib/Class/OWL.pm view on Meta::CPAN
} else {
$rdf->assert_literal( $subject, $predicate, $object );
}
}
sub to_rdf($) {
my ( $self, $i, $rdf ) = @_;
$rdf = $self->new_model() unless $rdf;
foreach my $t (@{$i->_type()}) {
$rdf->assert_resource( $i->_resource, 'rdf:type', $t );
}
view release on metacpan or search on metacpan
lib/Class/Prototyped.pm view on Meta::CPAN
#############################################################################
# Class::Prototyped - Fast prototype-based OO programming in Perl
package Class::Prototyped::Mirror;
sub PREFIX() { 'PKG0x' }
sub PREFIX_LENGTH() { 5 }
package Class::Prototyped;
use strict;
use Carp();
view release on metacpan or search on metacpan
inc/Test/More.pm view on Meta::CPAN
}
#line 425
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
$tb->cmp_ok(@_);
}
view release on metacpan or search on metacpan
t/01-simple.t view on Meta::CPAN
}
#################### prepare some subs
# object is "in sin", that is, not blessed.
sub in_sin($;$) {
my ($obj, $comment) = @_;
my $t = Test::More->builder;
$t->ok(! blessed($obj), $comment);
}
view release on metacpan or search on metacpan
lib/Class/Root.pm view on Meta::CPAN
while ( my ($k, $v ) = each %declare_subs ) {
gen_sub($k, $v);
}
sub method(;&) {
#print "method: ", Dumper(\@_);
my $sub = shift;
return "declare"->new( FLAGS => MF, SUB => $sub, OPTS => {} );
};
sub class_method(;&) {
#print "class_method: ", Dumper(\@_);
my $sub = shift;
return "declare"->new( FLAGS => CF|MF, SUB => $sub, OPTS => {} );
};
view release on metacpan or search on metacpan
lib/Class/Std/Fast.pm view on Meta::CPAN
sub _set_optimization_level {
$optimization_level_of{$_[0]} = $_[1] || 1;
}
# Prototype allows perl to inline ID
sub ID() {
return $instance_counter++;
}
sub ident ($) {
return ${$_[0]};
view release on metacpan or search on metacpan
bin/ct2pod.pl view on Meta::CPAN
}
}
}
}
sub read_pod(\*) {
my $fh = shift;
my @output;
while ( defined <$fh> ) {
push @output, $_;
view release on metacpan or search on metacpan
t/lib/TestUtils.pm view on Meta::CPAN
# If we have Test::FailWarnings, use it
BEGIN {
eval { require Test::FailWarnings; 1 } and do { Test::FailWarnings->import };
}
sub exception(&) {
my $code = shift;
my $success = eval { $code->(); 1 };
my $err = $@;
return '' if $success;
croak "Execution died, but the error was lost" unless $@;
view release on metacpan or search on metacpan
lib/Class/Trait.pm view on Meta::CPAN
use B qw/svref_2object/;
use Scalar::Util qw/blessed/;
warnings::warnif( 'deprecated', 'Class::Trait is deprecated and should no longer be used. Please use Role::Tiny or Role::Basic instead.' );
sub _croak($) {
my $message = shift;
require Carp;
Carp::croak($message);
}
view release on metacpan or search on metacpan
lib/Class/Validating.pm view on Meta::CPAN
my @ValidateArgsValidate = (
{ type => Params::Validate::ARRAYREF() },
{ type => Params::Validate::HASHREF(), optional => 1 }
);
sub validate_args(\@\%)
{
my $self = shift;
my($params, $extra_args) = Params::Validate::validate_pos(@_, @ValidateArgsValidate);
my $sub = (caller(1))[3];
view release on metacpan or search on metacpan
lib/Class/Variable.pm view on Meta::CPAN
our @EXPORT;
my $NS = {};
push @EXPORT, 'public';
sub public($;)
{
my @names = @_;
my $package = (caller)[0];
foreach my $name (@names)
{
lib/Class/Variable.pm view on Meta::CPAN
*{$package.'::'.$name } = get_public_variable($package, $name);
}
}
push @EXPORT, 'protected';
sub protected($;)
{
my @names = @_;
my $package = (caller)[0];
foreach my $name (@names)
{
lib/Class/Variable.pm view on Meta::CPAN
*{$package.'::'.$name } = get_protected_variable($package, $name);
}
}
push @EXPORT, 'private';
sub private($;)
{
my @names = @_;
my $package = (caller)[0];
foreach my $name (@names)
{
no strict 'refs';
*{$package.'::'.$name } = get_private_variable($package, $name);
}
}
sub get_public_variable($$)
{
my( $package, $name ) = @_;
return sub: lvalue
{
lib/Class/Variable.pm view on Meta::CPAN
$NS->{$self}->{$name};
};
}
sub get_protected_variable($$)
{
my( $package, $name ) = @_;
return sub: lvalue
{
lib/Class/Variable.pm view on Meta::CPAN
$NS->{$self}->{$name};
};
}
sub get_private_variable($$)
{
my( $package, $name ) = @_;
return sub: lvalue
{
view release on metacpan or search on metacpan
use strict;
use Test::Simple tests => 11;
use Class::Void;
sub is_empty_string($) {
return 1 if shift eq "";
return
}
my $null = Class::Void->bla->blub->foo->bar;
view release on metacpan or search on metacpan
extra/ForceLock.pm view on Meta::CPAN
use ClearCase::VobPathConv;
our $flk = '/usr/bin/locklbtype';
our $view = 'perl_view';
our $exec = '/opt/rational/clearcase/bin/cleartool setview -exec';
sub ssh() {
my $host = 'my.unix.sshd.host';
my $ssh = Net::SSH::Perl->new($host);
my $account = getlogin || getpwuid($<)
or die "Couldn't get the uid: $!\n";
$ssh->login($account);
return $ssh;
}
sub funlocklt($$) {
my ($lt, $vob) = @_;
$vob = winpath2ux($vob);
my($out, $err, $ret) = ssh()->cmd(
"$exec '$flk --unlock --vob $vob --lbtype $lt' $view");
print STDERR join("\n", grep(/^cleartool:/, split /\n/, $err), '') if $err;
print $out if $out;
return $ret;
}
sub flocklt($$;$$) {
my ($lt, $vob, $rep, $nusers) = @_;
$vob = winpath2ux($vob);
my $cmd = "$flk --vob $vob";
$cmd .= " --replace" if $rep;
$cmd .= " --nusers $nusers" if $nusers;
view release on metacpan or search on metacpan
t/05dtype.t view on Meta::CPAN
package Test::Hash;
@Test::Hash::ISA = qw( Clone::Any );
sub new()
{
my ($class) = @_;
my $self = {};
$self->{x} = 0;
$self->{x} = {value => 1};
view release on metacpan or search on metacpan
t/05dtype.t view on Meta::CPAN
package Test::Hash;
@Test::Hash::ISA = qw( Clone::AsUTF8Bytes );
sub new()
{
my ($class) = @_;
my $self = {};
$self->{x} = 0;
$self->{x} = {value => 1};
view release on metacpan or search on metacpan
t/05dtype.t view on Meta::CPAN
package Test::Hash;
@Test::Hash::ISA = qw( Clone::PP );
sub new()
{
my ($class) = @_;
my $self = {};
$self->{x} = 0;
$self->{x} = {value => 1};
view release on metacpan or search on metacpan
lib/Clone/Util.pm view on Meta::CPAN
use Function::Fallback::CoreOrPP qw(clone);
use Exporter qw(import);
our @EXPORT_OK = qw(clone modclone sclone);
sub modclone(&$;@) {
my $code = shift;
my $data = shift;
my $clone = clone($data);
local $_ = $clone;
$code->($clone);
lib/Clone/Util.pm view on Meta::CPAN
} else {
return $clone;
}
}
sub sclone($) {
my $data = shift;
my $ref = ref($data);
if ($ref eq 'ARRAY') {
return [@$data];
} elsif ($ref eq 'HASH') {
view release on metacpan or search on metacpan
t/05dtype.t view on Meta::CPAN
package Test::Hash;
@Test::Hash::ISA = qw( Clone );
sub new()
{
my ($class) = @_;
my $self = {};
$self->{x} = 0;
$self->{x} = {value => 1};
view release on metacpan or search on metacpan
lib/Closure/Explicit.pm view on Meta::CPAN
shift->method(++$x);
} weaken => [qw($self)], allowed => [qw($x)];
=cut
sub callback(&;@) {
if(CLOSURE_CHECKS) {
my $code = shift;
my %spec = (@_ > 1) ? (@_) : (allowed => shift);
# warn "Have " . join ',', keys %spec;
if(my @err = lint( $code => %spec )) {
view release on metacpan or search on metacpan
lib/Coat/Persistent.pm view on Meta::CPAN
return $self->{_db_state} ||= CP_ENTRY_NEW;
}
# DBIx::Sequence needs two tables in the schema,
# this private function create them if needed.
sub _create_dbix_sequence_tables($) {
my ($dbh) = @_;
# dbix_sequence_state exists ?
unless (_table_exists($dbh, 'dbix_sequence_state')) {
# nope, create!
lib/Coat/Persistent.pm view on Meta::CPAN
}
}
# This is the best way I found to check if a table exists, with a portable SQL
# If you have better, tell me!
sub _table_exists($$) {
my ($dbh, $table) = @_;
my $sth = $dbh->prepare("select count(*) from $table");
return 0 unless defined $sth;
$sth->execute or return 0;
my $nb_rows = $sth->fetchrow_hashref;
view release on metacpan or search on metacpan
lib/Code/TidyAll/Zglob.pm view on Meta::CPAN
#dbg("pattern: ", $node, $matcher);
return _rec($node, $matcher, []);
}
sub dbg(@) {
return unless $DEBUG;
my ($pkg, $filename, $line, $sub) = caller(1);
my $i = 0;
while (caller($i++)) { 1 }
my $msg;
view release on metacpan or search on metacpan
lib/CodeGen/Cpppp.pm view on Meta::CPAN
our $CURRENT_INDENT_PREFIX= '';
our $CURRENT_IS_INLINE= 0;
our $INDENT= ' ';
sub autoindent($self, $newval=undef) {
$self->{autoindent}= $newval if defined $newval;
$self->{autoindent} // 1;
}
sub autocolumn($self, $newval=undef) {
$self->{autocolumn}= $newval if defined $newval;
$self->{autocolumn} // 1;
}
sub convert_linecomment_to_c89($self, $newval=undef) {
$self->{convert_linecomment_to_c89}= $newval if defined $newval;
$self->{convert_linecomment_to_c89} // 0;
}
sub include_path { $_[0]{include_path} //= [] }
sub output { $_[0]{output} //= CodeGen::Cpppp::Output->new }
sub new($class, @attrs) {
my $self= bless {
@attrs == 1 && ref $attrs[0]? %{$attrs[0]}
: !(@attrs&1)? @attrs
: croak "Expected even-length list or hashref"
}, $class;
lib/CodeGen/Cpppp.pm view on Meta::CPAN
if defined $self->{include_path} && ref $self->{include_path} ne 'ARRAY';
$self;
}
sub require_template($self, $filename) {
$self->{templates}{$filename} ||= do {
my $path= $self->find_template($filename)
or croak("No template '$filename' found");
$self->{templates}{$path} ||= $self->compile_cpppp($path);
}
}
sub find_template($self, $filename) {
return abs_path($filename) if $filename =~ m,/, and -e $filename;
# /foo ./foo and ../foo do not trigger a path search
return undef if $filename =~ m,^\.?\.?/,;
for ($self->include_path->@*) {
my $p= "$_/$filename";
lib/CodeGen/Cpppp.pm view on Meta::CPAN
}
return undef;
}
sub new_template($self, $class_or_filename, @params) {
my $class= $class_or_filename =~ /^CodeGen::Cpppp::/ && $class_or_filename->can('new')
? $class_or_filename
: $self->require_template($class_or_filename);
my %params= (
context => $self,
lib/CodeGen/Cpppp.pm view on Meta::CPAN
$class->new(\%params);
}
our $next_pkg= 1;
sub compile_cpppp($self, @input_args) {
my $parse= $self->parse_cpppp(@input_args);
my $perl= $self->_gen_perl_template_package($parse);
unless (eval $perl) {
die "$perl\n\nException: $@\n";
}
return $parse->{package};
}
sub _gen_perl_template_package($self, $parse, %opts) {
my $perl= $parse->{code} // '';
my ($src_lineno, $src_filename, @global, $perl_ver, $cpppp_ver, $tpl_use_line)= (1);
# Extract all initial 'use' and 'no' statements from the script.
# If they refer to perl or CodeGen:::Cpppp, make a note of it.
while ($perl =~ s/^ ( [ \t]+ | [#] .* | use [^;]+ ; | no [^;]+ ; \s* ) \n//gx) {
lib/CodeGen/Cpppp.pm view on Meta::CPAN
# Everything after that goes into a BUILD method
$pkg->_gen_BUILD_method($cpppp_ver, $perl, $src_filename, $src_lineno),
"1";
}
sub parse_cpppp($self, $in, $filename=undef, $line=undef) {
my @lines;
if (ref $in eq 'SCALAR') {
@lines= split /^/m, $$in;
}
else {
lib/CodeGen/Cpppp.pm view on Meta::CPAN
$self->{cpppp_parse}{code}= $perl;
delete $self->{cpppp_parse};
}
sub _guess_indent($self, $indent_seen) {
my %evidence;
my $prev;
for (@$indent_seen) {
if (!defined $prev || length($_) <= length($prev)) {
$evidence{/^\t+$/? "\t" : /\t/? 'mixed_tabs' : $_}++;
lib/CodeGen/Cpppp.pm view on Meta::CPAN
|| ($evidence{$_} == $evidence{$guess} && $_ lt $guess);
}
return defined $guess && $guess eq 'mixed_tabs'? undef : $guess;
}
sub _transform_template_perl($self, $pl, $line) {
# If user declares "sub NAME(", convert that to "my sub NAME" so that it can
# capture refs to the variables of new template instances.
if ($pl =~ /^ \s* (my \s+)? sub \s* ([\w_]+) \b \s* /x) {
my $name= $2;
$self->{cpppp_parse}{template_method}{$name}= { line => $line };
lib/CodeGen/Cpppp.pm view on Meta::CPAN
substr($pl, $-[1], $-[2]-$-[1], qq{my sub $name; \$self->define_template_macro($name => \\&$name); sub });
}
$pl;
}
sub _gen_perl_call_code_block($self, $parsed, $indent='') {
my $codeblocks= $self->{cpppp_parse}{code_block_templates} ||= [];
push @$codeblocks, $parsed;
my $code= $indent.'$self->_render_code_block('.$#$codeblocks;
my %cache;
my $i= 0;
lib/CodeGen/Cpppp.pm view on Meta::CPAN
}
$code .= "\n$indent" if index($code, "\n") >= 0;
$code . ");\n";
}
sub _gen_perl_emit_pod_block($self, $pod, $file, $line, $indent='') {
my $pod_blocks= $self->{cpppp_parse}{pod_blocks} ||= [];
push @$pod_blocks, { pod => $pod, file => $file, line => $line };
return $indent.'$self->_render_pod_block('.$#$pod_blocks.");\n";
}
sub _finish_coltrack($coltrack, $col) {
# did it eventually have an eval to the left?
if (grep $_->{follows_eval}, $coltrack->{$col}{members}->@*) {
$coltrack->{$col}{members}[-1]{last}= 1;
} else {
# invalidate them all, they won't become unaligned anyway.
$_->{colgroup}= undef for $coltrack->{$col}{members}->@*;
}
delete $coltrack->{$col};
}
sub _parse_code_block($self, $text, $file=undef, $orig_line=undef) {
$text .= "\n" unless substr($text,-1) eq "\n";
if ($text =~ /^# line (\d+) "([^"]+)"/) {
$orig_line= $1-1;
$file= $2;
}
lib/CodeGen/Cpppp.pm view on Meta::CPAN
{ text => $text, subst => \@subst, file => $file }
}
sub patch_file($self, $fname, $patch_markers, $new_content) {
$new_content .= "\n" unless $new_content =~ /\n\Z/ or !length $new_content;
utf8::encode($new_content);
open my $fh, '+<', $fname or die "open($fname): $!";
my $content= do { local $/= undef; <$fh> };
$content =~ s{(BEGIN \Q$patch_markers\E[^\n]*\n).*?(^[^\n]+?END \Q$patch_markers\E)}
lib/CodeGen/Cpppp.pm view on Meta::CPAN
$fh->close or die "close: $!";
$self;
}
sub backup_and_overwrite_file($self, $fname, $new_content) {
$new_content .= "\n" unless $new_content =~ /\n\Z/;
utf8::encode($new_content);
if (-e $fname) {
my $n= 0;
++$n while -e "$fname.$n";
lib/CodeGen/Cpppp.pm view on Meta::CPAN
$fh->close or die "close: $!";
$self;
}
sub get_filtered_output($self, @sections) {
@sections= grep defined, @sections; # allow a single undef to mean 'all'
my $content= $self->output->get(@sections);
if ($self->convert_linecomment_to_c89) {
# rewrite '//' comments as '/*' comments
require CodeGen::Cpppp::CParser;
lib/CodeGen/Cpppp.pm view on Meta::CPAN
}
$content;
}
sub write_sections_to_file($self, $sections, $fname, $patch_markers=undef) {
my $content= $self->get_filtered_output($sections);
if (defined $patch_markers) {
$self->patch_file($fname, $patch_markers, $content);
} else {
$self->backup_and_overwrite_file($fname, $content);
}
$self
}
sub _slurp_file($self, $fname) {
open my $fh, '<', $fname or die "open($fname): $!";
my $content= do { local $/= undef; <$fh> };
$fh->close or die "close: $!";
$content;
}
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 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
Makefile.PL view on Meta::CPAN
requires 'MooseX::Daemonize' => undef;
build_requires 'Test::More' => '0';
no_index 'directory' => 'ex';
sub kwalitee() {
return <<'END';
use Test::More;
eval "use Test::Kwalitee";
plan skip_all => "Test::Kwalitee not installed; skipping" if $@;
END
view release on metacpan or search on metacpan
lib/Color/Library/Color.pm view on Meta::CPAN
;
sub rgb;
sub rgb2hex;
sub rgb2value;
sub value2rgb($);
sub parse_rgb_color;
sub integer2rgb($);
=head1 NAME
Color::Library::Color - Color entry for a Color::Library color dictionary
lib/Color/Library/Color.pm view on Meta::CPAN
Converts a numeric color value to its rgb representation
=cut
sub value2rgb($) {
my $value = shift;
my ($r, $g, $b);
$b = ($value & 0x0000ff);
$g = ($value & 0x00ff00) >> 8;
view release on metacpan or search on metacpan
lib/Color/Model/RGB.pm view on Meta::CPAN
W = [ 1 1 1 ]
=cut
# -----------------------------------------------------------------------------
sub O() { bless __PACKAGE__->SUPER::O(), __PACKAGE__ }
sub R() { bless __PACKAGE__->SUPER::X(), __PACKAGE__ }
sub G() { bless __PACKAGE__->SUPER::Y(), __PACKAGE__ }
sub B() { bless __PACKAGE__->SUPER::Z(), __PACKAGE__ }
sub W() { bless [ [[1,1,1]], 1,3 ], __PACKAGE__; }
# =============================================================================