Badger
view release on metacpan or search on metacpan
Added Badger::Storage, Badger::Storage::Memory. and
Badger::Storage::Filesystem.
Added Badger::Codec::TT.
Added the permissions() method to Badger::Filesystem::Path. Added
temp_directory() and temp_file() methods to Badger::Filesystem. Also
changed the Path(), File() and Dir() functions to short-circuit and
return if passed a single object that is already of the expected type.
Added some extra comparison methods to Badger::Timestamp (not_equal(),
(not_before() and not_after()) and overloaded these and other methods
onto the "==", "!=", "<", ">", "<=" and ">=" operators.
Added the export_before() and export_after() methods to
Badger::Exporter.
Added the if_env import hook and "-a|Badger::Test/all()" option to
Badger::Test to make it easier to define tests that don't get run unless
a particular environment variable is set (e.g. for Pod coverage/kwalitee
tests that you only want to run if either of the "RELEASE_TESTING" or
"AUTOMATED_TESTING" environment variables is set).
lib/Badger/App.pm view on Meta::CPAN
$self->debug("not found: $arg") if DEBUG;
return $self->error_msg( invalid => argument => $arg );
}
shift @$args;
$option->args($args, $self->{ app }, $self);
}
return $self;
# $self->debug("options schema for this app is: ", $schema);
# $self->not_implemented('in base class');
}
sub validate {
my $self = shift->prototype;
my $app = $self->{ app };
my $schema = $self->{ schema };
my ($item, $name);
foreach $item ($schema->items) {
lib/Badger/App.pm view on Meta::CPAN
path => $path,
apps => $apps,
);
};
}
sub run {
my $self = shift;
$self->validate;
$self->not_implemented('in base class');
}
#-----------------------------------------------------------------------
# output generation
#-----------------------------------------------------------------------
sub reporter {
my $self = shift->prototype;
my $config = @_ ? params(@_) : $self->{ app };
lib/Badger/Apps.pm view on Meta::CPAN
item => 'app';
sub found_module {
my ($self, $type, $module, $args) = @_;
$self->debug("Found module: $type => $module") if DEBUG;
$self->{ loaded }->{ $module } ||= class($module)->load;
return $module;
}
sub not_found {
my ($self, $type, @args) = @_;
return $self->decline_msg( not_found => $self->{ item }, $type );
}
1;
=head1 NAME
Badger::Apps - factory module for application modules
=head1 DESCRIPTION
lib/Badger/Apps.pm view on Meta::CPAN
This module implements a subclass of L<Badger::Factory> for loading and
instantiating L<Badger::App> application modules.
=head1 METHODS
The following methods are defined in addition to those inherited from the
L<Badger::Factory> and L<Badger::Base> base classes.
=head2 found_module($type, $module, @args)
=head2 not_found($type, @args)
=head1 AUTHOR
Andy Wardley L<http://wardley.org/>
=head1 COPYRIGHT
Copyright (C) 2008-2012 Andy Wardley. All Rights Reserved.
This module is free software; you can redistribute it and/or
lib/Badger/Base.pm view on Meta::CPAN
base_id => 'Badger', # stripped from class name to make id
TRIAL => 'Badger::Base::Trial',
};
use Badger::Exception; # TODO: autoload
use Badger::Debug 'debug debug_up dump_data_inline dump_data dump_list dump_hash';
our $EXCEPTION = 'Badger::Exception' unless defined $EXCEPTION;
our $ON_WARN = WARN;
our $MESSAGES = {
not_found => '%s not found: %s',
not_found_in => '%s not found in %s',
not_implemented => '%s is not implemented %s',
no_component => 'No %s component defined',
bad_method => "Invalid method '%s' called on %s at %s line %s",
invalid => 'Invalid %s specified: %s',
unexpected => 'Invalid %s specified: %s (expected a %s)',
missing_to => 'No %s specified to %s',
missing => 'No %s specified',
todo => '%s is TODO %s',
at_line => '%s at line %s',
at_file_line => '%s in %s at line %s',
};
lib/Badger/Base.pm view on Meta::CPAN
$_[0]->debug( message(@_) );
}
sub throw_msg {
my $self = shift;
$self->throw( shift, message($self, @_) );
}
#-----------------------------------------------------------------------
# generate not_implemented() and todo() methods
#-----------------------------------------------------------------------
class->methods(
map {
my $name = $_;
$name => sub {
my $self = shift;
my $ref = ref $self || $self;
my ($pkg, $file, $line, $sub) = caller(0);
$sub = (caller(1))[3]; # subroutine the caller was called from
$sub =~ s/(.*):://;
my $msg = @_ ? join(BLANK, SPACE, @_) : BLANK;
return $self->error_msg( $name => "$sub()$msg", "for $ref in $file at line $line" );
};
}
qw( not_implemented todo )
);
#-----------------------------------------------------------------------
# generate on_warn() and on_error() methods
#-----------------------------------------------------------------------
class->methods(
map {
my $on_event = $_;
lib/Badger/Base.pm view on Meta::CPAN
=head2 error_msg($message, @args)
This is a wrapper around the L<error()> and L<message()> methods,
similar to L<warn_msg()>.
package Your::Zoo;
use base 'Badger::Base';
our $MESSAGES = {
not_found => "I can't find the %s you asked for: %s",
}
sub animal {
my ($self, $name) = @_;
return $self->fetch_an_animal($name)
|| $self->error_msg( missing => animal => $name );
}
Calling the C<animal()> method on this object with an animal that can't
lib/Badger/Base.pm view on Meta::CPAN
Will generate an error message like this:
your.zoo error - I can't find the animal you asked for: Badgerpotamus
=head2 decline_msg($message, @args)
This is a wrapper around the L<decline()> and L<message()> methods,
similar to L<warn_msg()> and L<error_msg()>.
our $MESSAGES = {
not_found => 'No %s found in the forest',
};
sub forage {
my ($self, $name) = @_;
return $self->database->fetch_item($name)
|| $self->decline_msg( not_found => $name );
}
The L<reason()> method can be used to return the message generated.
my $food = $forager->forage('nuts')
|| warn $forager->reason; # No nuts found in the forest
=head2 fatal_msg($message, @args)
This is a wrapper around the L<fatal()> and L<message()> methods,
lib/Badger/Base.pm view on Meta::CPAN
This method is used internally to raise a fatal error. It bypasses the
normal error reporting mechanism and dies with a stack backtrace by calling
C<confess()> (see L<Carp>).
The most common reason for a fatal error being raised is calling the
L<message()> method (or either of the L<error_msg()> or L<decline_msg()>
wrapper methods) with a message format that doesn't exist. The stack backtrace
will tell you where in your code you're making the call so you can easily find
and fix it.
=head2 not_implemented($what)
A method of convenience which raises an error indicating that the method
isn't implemented
sub example_method {
shift->not_implemented;
}
Calling the C<example_method()> would result in an error message similar
to this (shown here split across two lines):
your.badger.module error - example_method() is not implemented
for Your::Badger::Module in /path/to/your/script.pl at line 42
Note that it tells you where the C<example_method()> was called from,
not where the method is defined.
The C<not_implemented()> method is typically used in methods defined in a base
classes that subclasses are expected to re-define (a.k.a. pure virtual methods
or abstract methods).
You can pass an argument to be more specific about what it is that
isn't implemented.
sub example_method {
shift->not_implemented('in base class');
}
The argument is added to the generated error message following the
method name. A single space is also added to separate them.
your.badger.module error - example_method() is not implemented in
base class for Your::Badger::Module in ...etc...
=head2 todo($what)
A method of convenience useful during developing to indicate that a method
isn't implemented yet. It raises an error stating that the method is
still TODO.
sub not_yet_working {
shift->todo;
}
The error message generated looks something like this:
your.badger.module error - not_yet_working() is TODO in
Your::Badger::Module at line 42
You can pass an argument to be more specific about what is still TODO.
sub not_yet_working {
my ($self, $x) = @_;
if (ref $x) {
$self->todo('support for references');
}
else {
# do something
}
}
The error message generated would then be:
your.badger.module error - not_yet_working() support for
references is TODO in Your::Badger::Module at line 42
=head2 debug($msg1,$msg2,...)
This method is mixed in from the L<Badger::Debug> module. It provides a simple
way of generating debugging messages which include the source module and line
number where the message was generated.
sub example {
my $self = shift;
lib/Badger/Base.pm view on Meta::CPAN
=head2 $MESSAGES
This package variable is used to reference a hash array of messages that can
be used with the L<message()>, L<warn_msg()>, L<error_msg()> and
L<decline_msg()> methods. The C<Badger::Base> module defines a number of
messages that it uses internally.
our $MESSAGES = {
not_found => '%s not found: %s',
not_found_in => '%s not found in %s',
not_implemented => '%s is not implemented %s',
no_component => 'No %s component defined',
bad_method => "Invalid method '%s' called on %s at %s line %s",
invalid => 'Invalid %s specified: %s',
unexpected => 'Invalid %s specified: %s (expected a %s)',
missing_to => 'No %s specified to %s',
missing => 'No %s specified',
todo => '%s is TODO %s',
at_line => '%s at line %s',
at_file_line => '%s in %s at line %s',
};
lib/Badger/Codec.pm view on Meta::CPAN
package Badger::Codec;
use Badger::Class
version => 0.01,
debug => 0,
base => 'Badger::Base',
utils => 'UTILS';
sub encode {
shift->not_implemented;
}
sub decode {
shift->not_implemented;
}
# This is the "brute force and ignorance" approach to creating stand-alone
# subroutines. They get the job done, albeit at the overhead of an extra
# method call. Subclasses can do something better, like exporting existing
# subrefs directly.
sub encoder {
my $self = shift;
lib/Badger/Comparable.pm view on Meta::CPAN
package Badger::Comparable;
use Badger::Class
version => 0.01,
debug => 0,
import => 'CLASS',
base => 'Badger::Base',
utils => 'numlike is_object',
methods => {
eq => \&equal,
ne => \¬_equal,
lt => \&before,
gt => \&after,
le => \¬_after,
ge => \¬_before,
cmp => \&compare,
},
overload => {
'==' => \&equal,
'!=' => \¬_equal,
'<' => \&before,
'>' => \&after,
'<=' => \¬_after,
'>=' => \¬_before,
'<=>' => \&compare,
fallback => 1,
};
sub compare {
my $self = shift;
shift->not_implemented;
}
sub equal {
shift->compare(@_) == 0;
}
sub not_equal {
shift->compare(@_) != 0;
}
sub before {
shift->compare(@_) == -1;
}
sub after {
shift->compare(@_) == 1;
}
sub not_before {
shift->compare(@_) >= 0;
}
sub not_after {
shift->compare(@_) <= 0;
}
1;
=head1 NAME
Badger::Comparable - base class for comparable objects
lib/Badger/Comparable.pm view on Meta::CPAN
The method can do whatever is necessary to compare the two objects. It should
return C<-1> if the C<$self> object should be ordered I<before> the C<$that>
object, C<+1> if it should be ordered I<after>, or 0 if the two objects are
considered the same.
=head2 equal($that)
Wrapper around L<compare()> that returns true if the two objects are equal
(L<compare()> returns C<0>).
=head2 not_equal($that)
Wrapper around L<compare()> that returns true if the two objects are not
equal (L<compare()> returns any non-zero value).
=head2 before($that)
Wrapper around L<compare()> that returns true if the C<$self> object is ordered
before the C<$that> object passed as an argument (L<compare()> returns C<-1>).
=head2 not_before($that)
Wrapper around L<compare()> that returns the logical opposite of the
L<before()> method, returning a true value if the C<$self> object is greater
than or equal to the L<$that> object passed as an argument (L<compare()>
returns C<0> or C<+1>).
=head2 after($that)
Wrapper around L<compare()> that returns true if the C<$self> object is ordered
after the C<$that> object passed as an argument (L<compare()> returns C<+1>).
=head2 not_after($that)
Wrapper around L<compare()> that returns the logical opposite of the
L<after()> method, returning a true value if the C<$self> object is less
than or equal to the L<$that> object passed as an argument (L<compare()>
returns C<-1> or C<0>).
=head1 OVERLOADED OPERATORS
=head2 ==
This is mapped to the L<equal()> method.
if ($obja == $objb) {
# do something
}
=head2 !=
This is mapped to the L<not_equal()> method.
if ($obja != $objb) {
# do something
}
=head2 <
This is mapped to the L<before()> method.
if ($obja < $objb) {
lib/Badger/Comparable.pm view on Meta::CPAN
=head2 >
This is mapped to the L<after()> method.
if ($obja > $objb) {
# do something
}
=head2 <=
This is mapped to the L<not_after()> method.
if ($obja <= $objb) {
# do something
}
=head2 >=
This is mapped to the L<not_before()> method.
if ($obja >= $objb) {
# do something
}
=head1 AUTHOR
Andy Wardley L<http://wardley.org>
=head1 COPYRIGHT
lib/Badger/Config/Filesystem.pm view on Meta::CPAN
$self->{ data } = $data;
$self->{ extensions } = $exts;
$self->{ match_ext } = $ext_re;
$self->{ codecs } = $codecs;
$self->{ encoding } = $encoding;
$self->{ filespec } = $filespec;
$self->{ quiet } = $config->{ quiet } || FALSE;
$self->{ dir_tree } = $config->{ dir_tree } // TRUE;
$self->{ stat_ttl } = $config->{ stat_ttl } // $data->{ stat_ttl } // $STAT_TTL;
$self->{ not_found } = { };
# Add any item schemas
$self->items( $config->{ schemas } )
if $config->{ schemas };
# Configuration file allows further data items (and schemas) to be defined
$self->init_file( $config->{ file } )
if $config->{ file };
return $self;
lib/Badger/Config/Filesystem.pm view on Meta::CPAN
}
#-----------------------------------------------------------------------------
# Filesystem-specific fetch methods
#-----------------------------------------------------------------------------
sub fetch {
my ($self, $uri) = @_;
return if $self->previously_not_found($uri);
$self->debug("fetch($uri)") if DEBUG or DEBUG_FETCH;
my $file = $self->config_file($uri);
my $dir = $self->dir($uri);
my $fok = $file && $file->exists;
my $dok = $dir && $dir->exists;
if ($dok) {
$self->debug("Found directory for $uri, loading tree") if DEBUG or DEBUG_FETCH;
lib/Badger/Config/Filesystem.pm view on Meta::CPAN
return $self->error_msg( load_fail => $file => $@ ) if $@;
return $self->tail(
$uri, $data,
$self->item_schema_from_data(
$uri, $data
)
);
}
$self->debug("No file or directory found for $uri") if DEBUG or DEBUG_FETCH;
$self->{ not_found }->{ $uri } = time();
return undef;
}
sub previously_not_found {
my ($self, $uri) = @_;
my $sttl = $self->{ stat_ttl } || return 0;
my $when = $self->{ not_found }->{ $uri } || return 0;
# we maintain the "not_found" status until stat_ttl seconds have elapsed
if (time < $when + $sttl) {
$self->debug("$uri NOT FOUND at $when") if DEBUG; # or DEBUG_FETCH;
return 1
}
else {
return 0;
}
}
#-----------------------------------------------------------------------------
lib/Badger/Config/Filesystem.pm view on Meta::CPAN
sub config_tree {
my $self = shift;
my $name = shift;
my $file = shift || $self->config_file($name);
my $dir = shift || $self->dir($name);
my $do_tree = $self->{ dir_tree };
my $data = undef; #{ };
my ($file_data, $binder, $more);
unless ($file && $file->exists || $dir->exists) {
return $self->decline_msg( not_found => 'file or directory' => $name );
}
# start by looking for a data file
if ($file && $file->exists) {
$file_data = $file->try->data;
return $self->error_msg( load_fail => $file => $@ ) if $@;
$self->debug("Read metadata from file '$file':", $self->dump_data($file_data)) if DEBUG;
}
# fetch a schema for this data item constructed from the default schema
lib/Badger/Config/Filesystem.pm view on Meta::CPAN
foreach my $ext (@$exts) {
my $path = $name.DOT.$ext;
my $file = $self->file($path);
if ($file->exists) {
$file->codec($self->codec($ext));
return $file;
}
}
return $self->decline_msg(
not_found => file => $name
);
}
sub write_config_file {
my ($self, $name, $data) = @_;
my $root = $self->root;
my $exts = $self->extensions;
my $ext = $exts->[0];
my $path = $name.DOT.$ext;
my $file = $self->file($path);
lib/Badger/Config/Item.pm view on Meta::CPAN
$self->debug(
"Configured configuration item: ", $self->dump
) if DEBUG;
return $self;
}
sub fallback {
shift->not_implemented;
}
sub names {
my $self = shift;
my @names = ($self->{ name }, keys %{ $self->{ alias } });
return wantarray
? @names
: \@names;
}
lib/Badger/Data/Facet.pm view on Meta::CPAN
# invalid => 'Invalid %s. %s',
# list_length => '%s should be %d elements long (got %d)',
# list_too_short => '%s should be at least %d elements long (got %d)',
# list_too_long => '%s should be at most %d elements long (got %d)',
# text_length => '%s should be %d characters long (got %d)',
# text_too_short => '%s should be at least %d characters long (got %d)',
# text_too_long => '%s should be at most %d characters long (got %d)',
# too_small => '%s should be no less than %d (got %d)',
# too_large => '%s should be no more than %d (got %d)',
# pattern => '%s does not match pattern: %s',
not_any => '%s does not match any of the permitted values: <3>',
# whitespace => 'Invalid whitespace option: %s (expected one of: %s)',
# not_number => '%s is not a number: <3>',
};
sub init {
my ($self, $config) = @_;
my $class = $self->class;
my ($option, @optional);
$self->debug("init() config is ", $self->dump_data($config)) if DEBUG;
lib/Badger/Data/Facet.pm view on Meta::CPAN
my $pkg = ref $self;
$pkg =~ /.*::(\w+)$/;
$1;
};
return $self;
}
sub validate {
shift->not_implemented;
}
sub invalid {
shift->error(@_);
}
sub invalid_msg {
my $self = shift;
lib/Badger/Data/Facet.pm view on Meta::CPAN
$self->invalid("The value specified is not valid");
=head2 invalid_msg($format,@args)
This method is used internally (e.g. by the L<validate()> method) to report
invalid values using a pre-defined L<message()|Badger::Base/message()>
format.
our $MESSAGES = {
not_orange => 'The colour specified is not orange: %s',
};
sub validate {
my ($self, $value) = @_;
return $$value eq 'orange'
|| $self->invalid_msg( not_orange => $$value );
}
=head1 PACKAGE VARIABLES
=head2 $MESSAGES
Subclasses may defined their own message formats (for use with
L<invalid_msg()>) using the C<$MESSAGES> package variable. This should
be a reference to a hash array mapping short names to message formats.
These formats are expanded using the C<xprintf()|Badger::Utils/xprintf()>
function in L<Badger::Utils>. This is a wrapper around C<sprintf()> with
some extra syntactic sugar for handling positional arguments.
our $MESSAGES = {
# messages taking one and two parameters
not_orange => 'The colour specified is not orange: %s',
not_colour => 'The colour specified is not %s: %s',
# message specifying parameters in a different order
alt_colour => 'You specified the colour <2> but that is not <1>.',
};
=head1 AUTHOR
Andy Wardley L<http://wardley.org/>
=head1 COPYRIGHT
lib/Badger/Data/Facet/Number.pm view on Meta::CPAN
package Badger::Data::Facet::Number;
use Badger::Class
version => 0.01,
base => 'Badger::Data::Facet',
utils => 'numlike',
messages => {
not_number => '%s is not a number (got %s)',
too_small => '%s should be no less than %d (got %d)',
too_large => '%s should be no more than %d (got %d)',
};
sub validate {
my ($self, $value, $type) = @_;
return numlike $$value
|| $self->invalid_msg( not_number => $type || 'Text', $$value );
}
1;
__END__
=head1 NAME
Badger::Data::Facet::Number - base class for numerical validation facets
lib/Badger/Data/Facet/Text.pm view on Meta::CPAN
package Badger::Data::Facet::Text;
use Badger::Class
version => 0.01,
base => 'Badger::Data::Facet',
utils => 'textlike',
messages => {
not_text => '%s is not text (got %s)',
wrong_length => '%s should be %d characters long (got %d)',
too_short => '%s should be at least %d characters long (got %d)',
too_long => '%s should be at most %d characters long (got %d)',
pattern => '%s does not match pattern: %s',
whitespace => 'Invalid whitespace option: %s (expected one of: %s)',
};
sub validate {
my ($self, $value, $type) = @_;
return textlike $$value
|| $self->invalid_msg( not_text => $type || 'Text', ref $value || $value );
}
1;
__END__
=head1 NAME
Badger::Data::Facet::Text - base class for text validation facets
lib/Badger/Data/Facet/tmp view on Meta::CPAN
# TODO: should we worry about numerical comparisons? In the original
# context of XML::Schema there was no need because all data originates
# from text documents and a text comparison is what defined equality.
# (e.g. 1.0 is not the same as 1)
foreach my $expect (@{ $self->{ values } }) {
return $value
if $value eq $expect;
}
return $self->invalid_msg( not_any => $type || 'Text', $self->{ values }, $value );
}
#-----------------------------------------------------------------------
# whitespace
#-----------------------------------------------------------------------
lib/Badger/Date.pm view on Meta::CPAN
if ($date1->after($date2)) {
print "$date1 is after $date2\n";
}
This method is overloaded onto the C<E<gt>> operator.
if ($date1 > $date2) {
print "$date1 is after $date2\n";
}
=head2 not_equal($when)
This is an alias to the L<compare()> method. It returns a true value (-1 or
+1, both of which Perl considers to be true values) if the dates are not
equal or false value (0) if they are.
if ($date1->not_equal($date2)) {
print "$date1 is not equal to $date2\n";
}
This method is overloaded onto the C<!=> operator.
if ($date1 != $date2) {
print "$date1 is not equal to $date2\n";
}
=head2 not_before($when)
This is a method of convenience which uses L<compare()> to test if one
date does not occur before another. It returns a true value (1) if the
first date (the object) is equal to or after the second (the argument),
or a false value (0) otherwise.
if ($date1->not_before($date2)) {
print "$date1 is not before $date2\n";
}
This method is overloaded onto the C<E<gt>=> operator.
if ($date1 >= $date2) {
print "$date1 is not before $date2\n";
}
=head2 not_after($when)
This is a method of convenience which uses L<compare()> to test if one
date does not occur after another. It returns a true value (1) if the
first date (the object) is equal to or before the second (the argument),
or a false value (0) otherwise.
if ($date1->not_after($date2)) {
print "$date1 is not after $date2\n";
}
This method is overloaded onto the C<E<lt>=> operator.
if ($date1 <= $date2) {
print "$date1 is not after $date2\n";
}
=head2 adjust(%adjustments)
lib/Badger/Factory.pm view on Meta::CPAN
# name (lower case dotted) to provide a case/syntax insensitve fallback
# (e.g. so "foo.bar" can match against "Foo.Bar", "Foo::Bar" and so on)
my $items = $self->{ $self->{ items } };
my $canon = dotid $type;
$self->debug("Looking for '$type' or '$canon' in $self->{ items }") if DEBUG;
# $self->debug("types: ", $self->dump_data($self->{ types })) if DEBUG;
# false but defined entry indicates the item is not found
return $self->not_found($type, \@args)
if exists $items->{ $type }
&& not $items->{ $type };
my $item = $items->{ $type }
|| $items->{ $canon }
# TODO: this needs to be defined-or, like //
# Plugins can return an empty string to indicate that they
# do nothing.
# HMMM.... or does it?
|| $self->find($type, \@args)
# || $self->default($type, \@args)
|| return $self->not_found($type, \@args);
$items->{ $type } = $item
unless $self->{ no_cache };
return $self->found($type, $item, \@args);
}
sub type_args {
# Simple method to grok $type and @args from argument list. The only
# processing it does is to set $type to 'default' if it is undefined or
lib/Badger/Factory.pm view on Meta::CPAN
sub found_array {
# This method is called when an ARRAY reference is found. We assume that
# the first item is the module name (which needs to be loaded) and the
# second item is the class name (which needs to be instantiated).
my ($self, $type, $item, $args) = @_;
my ($module, $class) = @$item;
$self->{ loaded }->{ $module } ||= class($module)->load;
return $self->construct($type, $class, $args);
}
sub not_found {
my ($self, $type, @args) = @_;
return $type eq DEFAULT
? $self->error_msg( no_default => $self->{ item } )
: $self->error_msg( not_found => $self->{ item }, $type );
}
sub construct {
my ($self, $type, $class, $args) = @_;
$self->debug("constructing class: $type => $class") if DEBUG;
return $class->new(@$args);
}
sub module_names {
my $self = shift;
lib/Badger/Factory.pm view on Meta::CPAN
This method is called at the end of a successful request after an object
has been instantiated (or perhaps re-used from an internal cache). In the
base class it simply returns C<$result> but can be redefined in a subclass
to do something more interesting.
=head2 module_names($type)
This method performs the necessary mapping from a requested module name to
its canonical form.
=head2 not_found($name,@args)
This method is called when the requested item is not found. The method simply
throws an error using the C<not_found> message format. The method can be
redefined in subclasses to perform additional fallback handing.
=head2 can($method)
This method implements the magic to ensure that the item-specific accessor
methods (e.g. C<widget()>/C<widgets()>) are generated on demand.
=head2 AUTOLOAD(@args)
This implements the other bit of magic to generate the item-specific accessor
lib/Badger/Filesystem/Path.pm view on Meta::CPAN
}
elsif (@$path == 1) {
# if there's a single item in a path then it's either a single
# relative path item (e.g. 'foo' ==> ['foo']), in which case we
# return the current working directory, or it's an empty item
# indicating the root directory (e.g. '/' => ['']) in which case we
# do nothing, because you can't go up from the root directory.
if (length $path->[0]) {
return $fs->cwd;
}
$self->not_implemented("going up from relative paths");
}
else {
$self->error("Invalid path (no elements)\n");
}
return $fs->join_directory($path);
}
sub exists {
shift->stat;
lib/Badger/Filesystem/Path.pm view on Meta::CPAN
$self->create(@_); # pass any other args, like dir file permission
}
else {
return $self->error_msg( no_exist => $self->type, $self->{ path } );
}
}
return $self;
}
sub create {
shift->not_implemented;
}
sub stat {
my $self = shift->must_exist;
my $stats = $self->filesystem->stat_path($self->{ path })
|| return $self->decline_msg( not_found => file => $self->{ path } );
# the definitive path can be tagged on the end
# $self->{ definitive } = $stats->[STAT_PATH]
# if defined $stats->[STAT_PATH];
return wantarray
? @$stats
: $stats;
}
lib/Badger/Filesystem/Visitor.pm view on Meta::CPAN
base => 'Badger::Base',
import => 'class',
utils => 'params',
constants => 'ARRAY CODE REGEX ON WILDCARD',
config => [
'files|accept|class:FILES',
'no_files|ignore|class:NO_FILES',
'dirs|directories|class:DIRS',
'no_dirs|no_directories|class:NO_DIRS',
'in_dirs|in_directories|enter|class:IN_DIRS',
'not_in_dirs|not_in_directories|leave|class:NOT_IN_DIRS',
'accept_file',
'reject_file',
'accept_dir|accept_directory',
'reject_dir|reject_directory',
'enter_dir|enter_directory',
'leave_dir|leave_directory',
],
messages => {
no_node => 'No node specified to %s',
bad_filter => 'Invalid test in %s specification: %s',
},
alias => {
init => \&init_visitor,
collect_dir => \&collect_dir,
enter_dir => \&enter_directory,
visit_dir => \&visit_directory,
visit_dir_kids => \&visit_directory_children,
};
use Badger::Debug ':dump';
our @FILTERS = qw( files dirs in_dirs no_files no_dirs not_in_dirs );
our $ALL = 0;
our $FILES = 1;
our $DIRS = 1;
our $IN_DIRS = 0;
our $NO_FILES = 0;
our $NO_DIRS = 0;
our $NOT_IN_DIRS = 0;
sub init_visitor {
lib/Badger/Filesystem/Visitor.pm view on Meta::CPAN
sub filter_directory {
my ($self, $dir) = @_;
return $self->filter( dirs => name => $dir )
&& ! $self->filter( no_dirs => name => $dir );
}
sub filter_entry {
my ($self, $dir) = @_;
return $self->filter( in_dirs => name => $dir )
&& ! $self->filter( not_in_dirs => name => $dir );
}
sub accept_file {
my ($self, $file) = @_;
$self->debug("accept_file($file)") if DEBUG;
$self->{ accept_file }->($self, $file)
if $self->{ accept_file };
return $self->collect($file);
lib/Badger/Filesystem/Visitor.pm view on Meta::CPAN
Badger::Filesystem::Visitor - visitor for traversing filesystems
=head1 SYNOPSIS
use Badger::Filesystem 'FS';
my $controls = {
files => '*.pm', # collect all *.pm files
dirs => 0, # ignore dirs
in_dirs => 1, # but do look in dirs for more files
not_in_dirs => ['.svn', '.git'], # don't look in these dirs
};
my @files = FS
->dir('/path/to/dir')
->visit($controls)
->collect;
=head1 DESCRIPTION
The L<Badger::Filesystem::Visitor> module implements a base class visitor
lib/Badger/Filesystem/Visitor.pm view on Meta::CPAN
$dir->visit(
files => '*.pm', # as above, no dirs are collected
dirs => 0, # but we do enter into them to
in_dirs => 1, # find more files
);
$dir->visit(
files => '*.pm', # collect *.pm files
dirs => 0, # don't collect dirs
in_dirs => 1, # do recurse into them
not_in_dirs => '.svn', # but don't look in .svn dirs
);
$dir->visit(
files => 'foo' # find all files named 'foo'
dirs => qr/ba[rz]/, # and all dirs named 'bar' or 'baz'
in_dirs => 1, # recurse into subdirs
);
You can also define subroutines to filter the files and/or directories that
you're interested in. The first argument passed to the subroutine is the
lib/Badger/Filesystem/Visitor.pm view on Meta::CPAN
);
In addition to the inclusive matches show above, you can also tell the visitor
what to exclude. You can use any of the same pattern specifications as for the
inclusive options (0/1 flags, names, regexen, subroutines, or list refs
containing any of the above).
$dir->visit(
no_files => '*.bak',
no_dirs => ['tmp', qr/backup/i],
not_in_dirs => ['.svn', '.DS_Store'],
);
When the visit is done, the L<collect()> method can be called to return
a list (in list context) or reference to a list (in scalar context) of the
items that were collected. The list will contain L<Badger::Filesystem::File>
and L<Badger::Filesystem::Directory> objects.
my $collect = $visitor->collect; # list ref in scalar context
my @collect = $visitor->collect; # list in list context
=head1 CONFIGURATION OPTIONS
NOTE: I'm planning the add the 'accept', 'ignore', 'enter', and 'leave'
aliases for 'files', 'no_files', 'in_dirs' and 'not_in_dirs'. Can't think
of better names for 'dirs' and 'no_dirs' though...
=head2 files / accept (todo)
A pattern specifier indicating the files that you want to match.
=head2 no_files / ignore (todo)
A pattern specifier indicating the files that you don't want to match.
lib/Badger/Filesystem/Visitor.pm view on Meta::CPAN
=head2 no_dirs / no_directories
A pattern specifier indicating the directories that you don't want to match.
=head2 in_dirs / in_directories / enter (todo)
A pattern specifier indicating the directories that you want to enter to
search for further files and directories.
=head2 not_in_dirs / not_in_directories / leave (todo)
A pattern specifier indicating the directories that you don't want to enter to
search for further files and directories.
=head2 at_file
A reference to a subroutine that you want called whenever a file of interest
(i.e. one that is included by L<files> and not excluded by L<no_files>) is
visited. The subroutine is passed a reference to the visitor object and
a reference to a L<Badger::Filesystem::File> object representing the file.
lib/Badger/Filesystem/Visitor.pm view on Meta::CPAN
$dir->visit(
at_dir => sub {
my ($visitor, $dir) = @_;
print "visiting dir: ", $dir->name, "\n";
}
);
If the function returns a true value then the visitor will continue to
visit any files or directories within it according to it's usual rules
(i.e. if the directory is listed in a L<not_in_dirs> rule then it won't
be entered). If the function returns a false value then the directory
will be skipped.
=head1 METHODS
=head2 new(\%params)
Constructor method to create a new C<Badger::Filesystem::Visitor>.
=head1 TRAVERSAL METHODS
lib/Badger/Modules.pm view on Meta::CPAN
${ $module.PKG.BADGER_LOADED } ||= 1;
$loaded->{ $module } = $module;
return $self->found( $name, $module );
}
}
# add entry to indicate module not found
$loaded->{ $name } = 0;
return $self->not_found($name);
}
sub found {
# my ($self, $name, $module) = @_;
return $_[2];
}
sub not_found {
my $self = shift;
return $self->{ tolerant }
? $self->decline_msg( not_found => $self->{ item } => @_ )
: $self->error_msg( not_found => $self->{ item } => @_ );
}
sub failed {
my $self = shift;
$self->error_msg( failed => $self->{ item }, @_ );
}
lib/Badger/Modules.pm view on Meta::CPAN
* name is expanded to various possible capitalisations
* each base namespace in path is tried...
* with each name...
* until one is located and loaded, in which case found() is called
(or failed() if an error occurred while loading the module)
* or we exhaust all possibilities, in which case not_found() is called.
=head2 modules()
This method can be used to get or set the internal mapping of names to
modules. It's not used at present... there's some more refactoring to be
done with L<Badger::Factory> to sort out how this is going to work.
=head2 path()
Method to get or set the module search path. It returns a reference to a
lib/Badger/Modules.pm view on Meta::CPAN
=head2 found($name,$module)
This method is called by the L<module()> method when a requested module
is found. The implementation in the base class simply returns the module
name passed to it as the second argument. This becomes the return value
for the successful invocation of the L<module()> method.
Subclasses may redefine this method to perform some other functionality.
=head2 not_found($name)
This method is called by the L<module()> method when a requested module cannot
be found. The default behaviour for this implementation in the base class
throws an error (via the L<error|Badger::Base/error()> method inherited from
the L<Badger::Base> base class). If the L<tolerant> configuration option is
set to a true value then it instead returns C<undef> by calling the
L<decline()|Badger::Base/decline()> method, also inherited from
L<Badger::Base>.
Subclasses may redefine this method to perform some other functionality.
lib/Badger/Period.pm view on Meta::CPAN
s => 1,
m => 60,
h => 60*60,
d => 60*60*24,
M => 60*60*24*30,
y => 60*60*24*365,
};
sub split_regex {
shift->not_implemented;
}
sub join_format {
shift->not_implemented;
}
sub text_format {
shift->join_format;
}
sub field_names {
my $class = shift;
my $names = $class->FIELD_NAMES
|| return $class->not_implemented;
$names = [ split(DELIMITER, $names) ]
unless ref $names eq ARRAY;
return wantarray
? @$names
: \@$names
}
lib/Badger/Test/Manager.pm view on Meta::CPAN
our $ESCAPES = qr/\e\[(.*?)m/; # remove ANSI escapes
our $REASON = 'No reason given';
our $MESSAGES = {
no_plan => "You haven't called plan() yet!\n",
dup_plan => "You called plan() twice!\n",
plan => "1..%s\n",
skip_all => "1..0 # skip %s\n",
skip_one => "ok %s # skip %s\n",
name => "test %s at %s line %s",
ok => "ok %s - %s\n",
not_ok => "not ok %s - %s\n%s",
not_eq => "# expect: [%s]\n# result: [%s]\n",
not_ne => "# unexpected match: [%s]\n",
not_like => "# expect: /%s/\n# result: [%s]\n",
not_unlike => "# expect: ! /%s/\n# result: [%s]\n",
too_few => "# Looks like you planned %s tests but only ran %s.\n",
too_many => "# Looks like you planned only %s tests but ran %s.\n",
no_result => "# result is undefined\n",
pass => "# PASS: All %d tests passed\n",
fail => "# FAIL: %d tests failed\n",
mess => "# FAIL: Inconsistent test results\n",
summary => "# %d/%d tests run, %d passed, %d failed, %d skipped\n",
hunk => "# -- diffs %s of %s --\n",
delta => "# %s %3d %s\n",
};
our $SCHEME = {
green => 'ok pass',
red => 'not_ok too_few too_many fail mess',
cyan => 'skip_one skip_all hunk delta',
yellow => 'plan not_eq not_ne not_like not_unlike summary',
};
# Sorry, English and American/Spanish only, no couleur, colori, farbe, etc.
*color = \&colour;
# for nice cleanup in END block
our $INSTANCES = { };
#-----------------------------------------------------------------------
lib/Badger/Test/Manager.pm view on Meta::CPAN
$_
} ($result, $expect);
if ($r ne $e) {
return $self->pass($msg);
}
else {
for ($expect, $result) {
s/\n/\n |/g;
}
return $self->fail($msg, $self->message( not_eq => $expect, $result ));
}
}
sub like ($$$;$) {
my $self = shift->prototype;
my ($result, $expect, $name) = @_;
$name ||= $self->test_name();
# strip ANSI escapes if necessary
my $r = $result;
$r =~ s/$ESCAPES//g if $self->{ colour };
if ($r =~ $expect) {
$self->pass($name);
}
else {
return $self->fail($name, $self->message( not_like => $expect, $result ));
}
}
sub unlike ($$$;$) {
my $self = shift->prototype;
my ($result, $expect, $name) = @_;
$name ||= $self->test_name();
# strip ANSI escapes if necessary
my $r = $result;
$r =~ s/$ESCAPES//g if $self->{ colour };
if ($r !~ $expect) {
$self->pass($name);
}
else {
return $self->fail($name, $self->message( not_unlike => $expect, $result ));
}
}
sub skip ($;$) {
my $self = shift->prototype;
my $msg = shift || $self->test_name;
return $self->error_msg('no_plan')
unless $self->{ plan };
lib/Badger/Test/Manager.pm view on Meta::CPAN
return $self->error_msg('no_plan')
unless $self->{ plan };
if ($ok) {
$self->{ passed }++;
return $self->test_msg( ok => @_ );
}
else {
$self->{ failed }++;
return $self->test_msg( not_ok => @_ );
}
}
sub test_msg {
my $self = shift;
print $self->message(@_);
}
sub test_name ($) {
my $self = shift->prototype;
my ($pkg, $file, $line) = caller(2);
$self->message( name => $self->{ count }, $file, $line );
}
sub different {
my ($self, $expect, $result) = @_;
my ($pad_exp, $pad_res) = ($expect, $result);
for ($pad_exp, $pad_res) {
s/\n/\n# |/g;
}
my $msg = $self->message( not_eq => $pad_exp, $pad_res );
return $msg
unless $CAN_DIFF;
my $diffs = diff( map { [ split(/\n/) ] } $expect, $result );
my $n = 0;
my $m = scalar @$diffs;
foreach my $hunk (@$diffs) {
$msg .= $self->message( hunk => ++$n, $m );
lib/Badger/Timestamp.pm view on Meta::CPAN
use Badger::Class
version => 0.03,
debug => 0,
import => 'class CLASS',
base => 'Badger::Base',
utils => 'numlike self_params is_object',
accessors => 'timestamp',
as_text => 'timestamp',
is_true => 1,
methods => {
not_equal => \&compare,
},
overload => {
'!=' => \¬_equal,
'==' => \&equal,
'<' => \&before,
'>' => \&after,
'<=' => \¬_after,
'>=' => \¬_before,
fallback => 1,
},
constants => 'HASH',
constant => {
TS => __PACKAGE__,
TIMESTAMP => __PACKAGE__,
},
exports => {
any => 'TS TIMESTAMP Timestamp Now',
},
lib/Badger/Timestamp.pm view on Meta::CPAN
}
sub before {
shift->compare(@_) == -1;
}
sub after {
shift->compare(@_) == 1;
}
sub not_before {
shift->compare(@_) >= 0;
}
sub not_after {
shift->compare(@_) <= 0;
}
sub tm_wday {
my $self = shift;
return (localtime($self->epoch_time))[6];
}
sub days_in_month {
my $self = shift;
lib/Badger/Timestamp.pm view on Meta::CPAN
if ($time1->after($time2)) {
print "time1 is after time2\n";
}
This method is overloaded onto the C<E<gt>> operator.
if ($time1 > $time2) {
print "time1 is after time2\n";
}
=head2 not_equal($when)
This is an alias to the L<compare()> method. It returns a true value (-1 or
+1, both of which Perl considers to be true values) if the timestamps are not
equal or false value (0) if they are.
if ($time1->not_equal($time2)) {
print "time1 is not equal to time2\n";
}
This method is overloaded onto the C<!=> operator.
if ($time1 != $time2) {
print "time1 is not equal to time2\n";
}
=head2 not_before($when)
This is a method of convenience which uses L<compare()> to test if one
timestamp does not occur before another. It returns a true value (1) if the
first timestamp (the object) is equal to or after the second (the argument),
or a false value (0) otherwise.
if ($time1->not_before($time2)) {
print "time1 is not before time2\n";
}
This method is overloaded onto the C<E<gt>=> operator.
if ($time1 >= $time2) {
print "time1 is not before time2\n";
}
=head2 not_after($when)
This is a method of convenience which uses L<compare()> to test if one
timestamp does not occur after another. It returns a true value (1) if the
first timestamp (the object) is equal to or before the second (the argument),
or a false value (0) otherwise.
if ($time1->not_after($time2)) {
print "time1 is not after time2\n";
}
This method is overloaded onto the C<E<lt>=> operator.
if ($time1 <= $time2) {
print "time1 is not after time2\n";
}
=head2 adjust(%adjustments)
pod/Badger/Changes.pod view on Meta::CPAN
Added the L<permissions()|Badger::Filesystem::Path/permissions()> method to
L<Badger::Filesystem::Path>. Added
L<temp_directory()|Badger::Filesystem/temp_directory()> and
L<temp_file()|Badger::Filesystem/temp_file()> methods to
L<Badger::Filesystem>. Also changed the L<Path()|Badger::Filesystem/Path()>,
L<File()|Badger::Filesystem/File()> and L<Dir()|Badger::Filesystem/Dir()>
functions to short-circuit and return if passed a single object that is
already of the expected type.
Added some extra comparison methods to L<Badger::Timestamp>
(L<not_equal()|Badger::Timestamp/not_equal()>,
(L<not_before()|Badger::Timestamp/not_before()> and
L<not_after()|Badger::Timestamp/not_after()>) and overloaded
these and other methods onto the C<==>, C<!=>, C<E<lt>>, C<E<gt>>, C<E<lt>=>
and C<E<gt>=> operators.
Added the L<export_before()|Badger::Exporter/export_before()> and
L<export_after()|Badger::Exporter/export_after()> methods to
L<Badger::Exporter>.
Added the L<if_env|Badger::Test/if_env> import hook and
C<-a|Badger::Test/all()> option to L<Badger::Test> to make it easier to
define tests that don't get run unless a particular environment variable
t/core/base.t view on Meta::CPAN
# error_msg()
#------------------------------------------------------------------------
package My::Base;
use base qw( Badger::Base );
our $MESSAGES = {
no_pony => 'Missing pony! (got "%s")',
no_buffy => 'Missing Buffy! (got %s and %s)',
one_louder => '%1$s. Exactly. %2$s louder',
not_ten => "Well, it's %2\$s louder, isn't it? It's not %1\$s.",
};
package main;
$base = My::Base->new();
eval { $base->error_msg( no_pony => 'donkey' ) };
ok( $@, 'pony error' );
is( $base->error(), 'Missing pony! (got "donkey")', 'no pony!' );
eval { $base->error_msg( no_buffy => 'Angel', 'Willow' ) };
ok( $@, 'Buffy error' );
is( $base->error(), 'Missing Buffy! (got Angel and Willow)', 'no Buffy!' );
eval { $base->error_msg( one_louder => 'Eleven', 'One' ) };
ok( $@, 'One louder error' );
is( $base->error(), 'Eleven. Exactly. One louder', 'Eleven is one louder' );
eval { $base->error_msg( not_ten => 'ten', 'one' ) };
ok( $@, 'Not ten error' );
is( $base->error(), "Well, it's one louder, isn't it? It's not ten.", "It's not ten" );
#------------------------------------------------------------------------
# error_msg() with subclass
#------------------------------------------------------------------------
package My::Sub;
use base qw( My::Base );
t/core/base.t view on Meta::CPAN
$complainer = My::OnError->new( throws => 'umbrella' );
eval { $complainer->error("it's pouring") };
ok( $@, "it's pouring" );
is( $My::OnError::COMPLAINT[1], "it's pouring", "pouring error reported" );
is( $@->type, "umbrella", "umbrella error type" );
is( $@->info, "it's pouring", "umbrella error info" );
#-----------------------------------------------------------------------
# test the not_implemented() and todo() methods
#-----------------------------------------------------------------------
our ($foo_line, $bar_line, $wam_line, $bam_line) = (0) x 4;
package My::Incomplete;
use base 'Badger::Base';
sub foo {
$main::foo_line = __LINE__ + 1;
shift->not_implemented;
}
sub bar {
$main::bar_line = __LINE__ + 1;
shift->not_implemented('first test case');
}
sub wam {
$main::wam_line = __LINE__ + 1;
shift->todo;
}
sub bam {
$main::bam_line = __LINE__ + 1;
shift->todo('second test case');
t/core/base.t view on Meta::CPAN
#-----------------------------------------------------------------------
package Danger::Mouse;
use base 'Badger::Base';
sub hurl {
shift->error("HURLING: ", @_);
}
sub missing {
shift->not_implemented;
}
sub not_done {
my $self = shift;
my $item = shift || $self->todo;
$self->todo('with argument');
}
sub sensitive {
return wantarray
? ('called', 'in', 'list', 'context')
: 'called in scalar context';
}
t/core/base.t view on Meta::CPAN
my $mouse = Danger::Mouse->new();
ok( ! eval { $mouse->hurl('cheese') }, 'eval failed' );
is( $@, 'danger.mouse error - HURLING: cheese', 'danger mouse error' );
ok( ! $mouse->try( hurl => 'cheese' ), 'try failed' );
is( $mouse->reason, 'danger.mouse error - HURLING: cheese', 'danger mouse error' );
ok( ! $mouse->try('missing'), 'try missing' );
like( $mouse->reason, qr/danger\.mouse error - missing\(\) is not implemented for Danger::Mouse/, 'danger mouse missing' );
ok( ! $mouse->try('not_done'), 'not_done' );
like( $mouse->reason, qr/danger\.mouse error - not_done\(\) is TODO for Danger::Mouse/, 'danger mouse todo' );
ok( ! $mouse->try( not_done => 10 ), 'not_done with arg' );
like( $mouse->reason, qr/danger\.mouse error - not_done\(\) with argument is TODO for Danger::Mouse/, 'danger mouse todo' );
my $result = $mouse->try('sensitive');
is( $result, 'called in scalar context', 'try() preserves scalar context' );
my @result = $mouse->try('sensitive');
is( join(', ', @result), 'called, in, list, context', 'try() preserves list context' );
#-----------------------------------------------------------------------
# test try nomad
#-----------------------------------------------------------------------
ok( ! $mouse->try->hurl('cheese'), 'try trial failed' );
is( $mouse->reason, 'danger.mouse error - HURLING: cheese', 'danger mouse trial error' );
ok( ! $mouse->try->missing, 'try trial missing' );
like( $mouse->reason, qr/danger\.mouse error - missing\(\) is not implemented for Danger::Mouse/, 'danger mouse trial missing' );
ok( ! $mouse->try->not_done, 'trial not_done' );
like( $mouse->reason, qr/danger\.mouse error - not_done\(\) is TODO for Danger::Mouse/, 'danger mouse trial todo' );
ok( ! $mouse->try->not_done(10), 'not_done trial with arg' );
like( $mouse->reason, qr/danger\.mouse error - not_done\(\) with argument is TODO for Danger::Mouse/, 'danger mouse trial todo' );
$result = $mouse->try->sensitive;
is( $result, 'called in scalar context', 'try-> preserves scalar context' );
@result = $mouse->try->sensitive;
is( join(', ', @result), 'called, in, list, context', 'try-> preserves list context' );
#-----------------------------------------------------------------------
t/core/date.t view on Meta::CPAN
is($today->year, $year, 'year today' );
my $tomorrow = $today->copy->adjust( days => 1 );
#print "tomorrow: $tomorrow\n";
ok( $tomorrow->after($today), "tomorrow is after today" );
ok( $today->before($tomorrow), "today is before tomorrow" );
ok( ! $tomorrow->before($today), "tomorrow is not before today" );
ok( ! $today->after($tomorrow), "today is not after tomorrow" );
ok( $tomorrow->not_before($today), "tomorrow is not_before today" );
ok( $today->not_after($tomorrow), "today is not_after tomorrow" );
ok( $tomorrow > $today, "tomorrow > today" );
ok( $today < $tomorrow, "today < tomorrow" );
ok( !( $tomorrow < $today ), "not tomorrow < today" );
ok( !( $today > $tomorrow ), "not today > tomorrow" );
print $today->date, "\n";
print $today->format('%d-%b-%y');
t/core/lib/My/Mixin/Bar.pm view on Meta::CPAN
use Badger::Class
version => 0.01,
debug => 0,
base => 'Badger::Mixin',
# mixin => 'Badger::Mixin::Messages';
utils => 'xprintf',
import => 'class',
constants => 'BLANK SPACE',
mixins => '$MESSAGES message warn_msg error_msg decline_msg
not_implemented todo';
our $MESSAGES = {
hello => 'Hello %s!',
};
sub message {
my $self = shift;
my $name = shift
|| $self->fatal("message() called without format name");
my $format = $self->class->hash_value( MESSAGES => $name )
t/core/lib/My/Mixin/Bar.pm view on Meta::CPAN
}
sub decline_msg {
my $self = shift;
$self->decline( $self->message(@_) );
}
1;
#-----------------------------------------------------------------------
# generate not_implemented() and todo() methods
#-----------------------------------------------------------------------
class->methods(
map {
my $name = $_;
$name => sub {
my $self = shift;
my $ref = ref $self || $self;
my ($pkg, $file, $line, $sub) = caller(0);
$sub = (caller(1))[3]; # subroutine the caller was called from
$sub =~ s/(.*):://;
my $msg = @_ ? join(BLANK, SPACE, @_) : BLANK;
return $self->error_msg( $name => "$sub()$msg", "for $ref in $file at line $line" );
};
}
qw( not_implemented todo )
);
1;
t/core/timestamp.t view on Meta::CPAN
#-----------------------------------------------------------------------
# test before(), after() and equal()
#-----------------------------------------------------------------------
my $old = Timestamp->new('2009-07-05 12:47:42');
my $new = Timestamp->new('2009-07-05 16:20:00');
ok( $old->equal($old), 'old is equal to old' );
ok( $new->equal($new), 'new is equal to new' );
ok( $old->not_equal($new), 'old is not equal to new' );
ok( $new->not_equal($old), 'new is not equal to old' );
# before/after/compare/equal all accept another timestamp...
ok( $old->before($new), 'old is before new' );
ok( $new->after($old), 'new is after old' );
# ...or a time in epoch seconds...
ok( $old->before($new->epoch_time), 'old is before new epoch time' );
ok( $new->after($old->epoch_time), 'new is after old epoch time' );
# ...or a timestamp...
t/filesystem/visitor.t view on Meta::CPAN
recurse => 1,
dirs => 0,
files => ['foo', 'bar'],
)->collect;
is( scalar @files, 5, 'got 5 foo and bar files' );
@files = $tdir->visit(
dirs => 0,
files => qr/foo|bar/,
in_dirs => 1,
not_in_dirs => '.svn',
)->collect;
is( scalar @files, 5, 'got 5 foo or bar files via regex' );
#-----------------------------------------------------------------------
# wildcards
#-----------------------------------------------------------------------
# all html files
@files = $vdir->visit(
dirs => 0,
files => '*.html',
in_dirs => 1,
not_in_dirs => '.svn',
)->collect;
print STDERR "HTML files: \n", join("\n ", @files), "\n" if $DEBUG;
is( scalar @files, 2, 'got 2 HTML files' );
is( join(' ', sort map { $_->name } @files),
'goodbye.html hello.html',
'got all HTML files' );
# all goodbye files with a 3 character extension
@files = $vdir->visit(
dirs => 0,
files => 'goodbye.???',
in_dirs => 1,
not_in_dirs => '.svn',
)->collect;
print STDERR "goodbye files: \n", join("\n ", @files), "\n" if $DEBUG;
is( scalar @files, 2, 'got 2 goodbye files' );
is( join(' ', sort map { $_->name } @files),
'goodbye.bak goodbye.txt',
'got all goodbye files' );
# same again using wilder wildcard (checks that '.' is not wild)
@files = $vdir->visit(
dirs => 0,
files => '*.???',
in_dirs => 1,
not_in_dirs => ['.svn', 'tm?'],
)->collect;
print STDERR "wild files: \n", join("\n ", @files), "\n" if $DEBUG;
is( scalar @files, 3, 'got 3 wild files' );
is( join(' ', sort map { $_->name } @files),
'goodbye.bak goodbye.txt hello.txt',
'got all wild files' );
# same again with tighter wildcard
@files = $vdir->visit(
dirs => 0,
files => 'g*.???',
in_dirs => 1,
not_in_dirs => ['.svn', 'tm?'],
)->collect;
print STDERR "wild goodbye files: \n", join("\n ", @files), "\n" if $DEBUG;
is( scalar @files, 2, 'got 2 wild goodbye files' );
is( join(' ', sort map { $_->name } @files),
'goodbye.bak goodbye.txt',
'got all wild goodbye files' );
t/filesystem/visitor.t view on Meta::CPAN
#-----------------------------------------------------------------------
# subroutine filters
#-----------------------------------------------------------------------
# small files
@files = $vdir->visit(
dirs => 0,
files => sub { shift->size < 100 },
in_dirs => 1,
not_in_dirs => '.svn',
)->collect;
print STDERR "small files: \n", join("\n ", @files), "\n" if $DEBUG;
is( scalar @files, 6, 'got 6 small files' );
is( join(' ', sort map { $_->name } @files),
'README goodbye.bak hello.txt mushroom small snake',
'got all small files' );
# medium files
@files = $vdir->visit(
dirs => 0,
files => sub { my $size = shift->size; $size >= 100 && $size < 420 },
in_dirs => 1,
not_in_dirs => '.svn',
)->collect;
print STDERR "medium files: \n", join("\n ", @files), "\n" if $DEBUG;
is( scalar @files, 3, 'got 3 medium files' );
is( join(' ', sort map { $_->name } @files),
'badger goodbye.txt medium',
'got all small files' );
# large files
@files = $vdir->visit(
dirs => 0,
files => sub { shift->size > 420 },
in_dirs => 1,
not_in_dirs => ['.svn', 'tmp'],
)->collect;
print STDERR "large files: \n", join("\n ", @files), "\n" if $DEBUG;
is( scalar @files, 3, 'got 3 large files' );
is( join(' ', sort map { $_->name } @files),
'goodbye.html hello.html large',
'got all large files' );
# directories containing a README file
@files = $vdir->visit(
dirs => sub { shift->file('README')->exists },
files => 0,
in_dirs => 1,
not_in_dirs => '.svn',
)->collect;
print STDERR "dirs with README files: \n", join("\n ", @files), "\n" if $DEBUG;
is( scalar @files, 1, 'got 1 dir with README' );
is( join(' ', sort map { $_->name } @files),
'tmp',
'got all dirs with README files in' );
( run in 1.412 second using v1.01-cache-2.11-cpan-cc502c75498 )