Badger
view release on metacpan or search on metacpan
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).
Added the random_name(), camel_case() and permute_fragments() functions
to Badger::Utils. Also add some extra debugging code to params() and
self_params() to catch any attempt to pass an odd number of arguments.
Changed the Badger::Factory module to use permute_fragments() on the
module path when specified as a single string. Also added the default()
and names() methods along with their corresponding package variable
magic.
Added the debug_callers(), debugf() and debug_at() methods to
Badger::Debug.
Added the alias() method to Badger::Class.
Added the auto_can() method to Badger::Class::Methods.
lib/Badger/Factory/Class.pm view on Meta::CPAN
package Badger::Factory::Class;
use Carp;
use Badger::Class
version => 0.01,
debug => 0,
uber => 'Badger::Class',
hooks => 'item path names default',
words => 'ITEM ITEMS',
utils => 'plural permute_fragments',
import => 'CLASS',
constants => 'DELIMITER ARRAY HASH',
constant => {
PATH_SUFFIX => '_PATH',
NAMES_SUFFIX => '_NAMES',
FACTORY => 'Badger::Factory',
};
# chicken and egg
# exports => {
# fail => \&_export_fail_hook,
lib/Badger/Factory/Class.pm view on Meta::CPAN
return $self;
}
sub path {
my ($self, $path) = @_;
my $type = $self->var(ITEM)
|| croak "\$ITEM is not defined for $self. Please add an 'item' option";
my $var = uc($type) . PATH_SUFFIX;
$path = [ map { permute_fragments($_) } split(DELIMITER, $path) ]
unless ref $path eq ARRAY;
$self->debug("adding $var => [", join(', ', @$path), "]") if DEBUG;
# $self->base(FACTORY);
# we use import_symbol() rather than var() so that it gets declared
# properly, thus avoiding undefined symbol warnings
$self->import_symbol( $var => \$path );
return $self;
lib/Badger/Factory/Class.pm view on Meta::CPAN
path => 'My::Widget Your::Widget';
If you specify it as a single string then you can also include optional
and/or alternate parts in parentheses. For example the above can be
written more concisely as:
use Badger::Factory::Class
item => 'widget',
path => '(My|Your)::Widget';
If the parentheses don't contain a vertical bar then then enclosed fragment
is treated as being optional. So instead of writing something like:
use Badger::Factory::Class
item => 'widget',
path => 'Badger::Widget BadgerX::Widget';
You can write:
use Badger::Factory::Class
item => 'widget',
path => 'Badger(X)::Widget';
See the L<permute_fragments()|Badger::Utils/permute_fragments()> function in
L<Badger::Utils> for further details on how fragments are expanded.
=head2 names($names)
A reference to a hash array of name mappings. This can be used to handle any
unusual spellings or capitalisations. See L<Badger::Factory> for further
details.
=head2 default($name)
The default name to use when none is specified in a request for a module.
lib/Badger/Modules.pm view on Meta::CPAN
modules under the C<Your::App::Plugin> namespace by default.
Subclasses can also override methods to change the way it works or affect what
happens after a module is loaded. The L<Badger::Factory> module is an example
of such a module. It provides additional methods for dynamically creating
objects and relies on the underlying functionality provided by
C<Badger::Modules> to ensure that the relevant modules are loaded.
=head2 What's the Problem?
Consider the following code fragment showing a subroutine that creates and
uses a C<Your::App::Widget> object.
use Your::App::Widget;
sub some_code {
my $widget = Your::App::Widget->new;
$widget->do_something;
}
One of the benefits of object oriented programming is that objects of
lib/Badger/URL.pm view on Meta::CPAN
url => \&text,
},
exports => {
any => 'URL',
};
#------------------------------------------------------------------------
# Example URL:
#
# scheme authority path query fragment
# __ ___________________ _________ _________ __
# / \ / \/ \ / \ / \
# http://user@example.com:8042/over/there?name=ferret#nose
# \__/ \_________/ \__/
# user host port
#
#------------------------------------------------------------------------
our @ELEMENTS = qw(
scheme authority user host port path query fragment params
);
our $N_ELEMS = 1; # slot 0 holds source text, so slot 1 is first field
our $ELEMENT = {
map { $_ => $N_ELEMS++ }
@ELEMENTS
};
# regexen to match basic tokens
our $MATCH_SCHEME = qr{ ( [a-zA-Z][a-zA-Z0-9.+\-]* ) : }x;
our $MATCH_USER = qr{ ([^@]*) @ }x;
lib/Badger/URL.pm view on Meta::CPAN
(?: $MATCH_PORT )? # $4 - port
)
}x;
# compound regexen to match complete URL
our $MATCH_URL = qr{
^ (?: $MATCH_SCHEME )? # $1 - scheme
(?: $MATCH_AUTHORITY )? # $2,$3,$4,$5 - authority,user,host,port
$MATCH_PATH # $6 - path
(?: $MATCH_QUERY )? # $7 - query
(?: $MATCH_FRAGMENT )? # $8 - fragment
}x;
#------------------------------------------------------------------------
# Constructor function and methods.
#------------------------------------------------------------------------
sub URL {
return CLASS unless @_;
lib/Badger/URL.pm view on Meta::CPAN
sort keys %$params # sorted makes debugging easier
));
}
sub join_url {
my $self = shift;
my $scheme = $self->[SCHEME];
my $auth = $self->[AUTHORITY];
my $query = $self->[QUERY];
my $frag = $self->[FRAGMENT];
$scheme = (defined $scheme && length $scheme) ? $scheme . ':' : BLANK;
$auth = (defined $auth && length $auth) ? '//' . $auth : BLANK;
$query = (defined $query && length $query) ? '?' . $query : BLANK;
$frag = (defined $frag && length $frag) ? '#' . $frag : BLANK;
return ($self->[TEXT] = $scheme.$auth.$self->[PATH].$query.$frag);
}
#-----------------------------------------------------------------------
# accessor/mutator methods
#-----------------------------------------------------------------------
sub text {
$_[0]->[TEXT];
lib/Badger/URL.pm view on Meta::CPAN
[host => HOST],
[port => PORT],
);
class->methods(
map {
my ($name, $slot) = @$_;
$name => sub {
my $self = shift;
if (@_) {
# if either of the path or fragment are updated then we
# must regenerate the complete URL
$self->[$slot] = shift;
$self->join_url;
}
return $self->[$slot];
}
}
[path => PATH],
[fragment => FRAGMENT],
);
1;
__END__
=head1 NAME
Badger::URL - representation of a Uniform Resource Locator (URL)
lib/Badger/URL.pm view on Meta::CPAN
);
# named parameters
my $url = Badger::URL->new(
scheme => 'http',
user => 'abw',
host => 'badgerpower.com',
port => '8080',
path => '/under/ground',
query => 'animal=badger',
fragment => 'stripe',
);
# methods to access standard W3C parts of URL
print $url->scheme; # http
print $url->authority; # abw@badgerpower.com:8080
print $url->user; # abw
print $url->host; # badgerpower.com
print $url->port; # 8080
print $url->path; # /under/ground
print $url->query; # animal=badger
print $uri->fragment; # stripe
# additional composite methods:
print $url->server;
# http://abw@badgerpower.com:8080
print $url->service;
# http://abw@badgerpower.com:8080/under/ground
print $url->request;
# http://abw@badgerpower.com:8080/under/ground?animal=badger
lib/Badger/URL.pm view on Meta::CPAN
The emphasis is on simplicity and convenience for tasks related to web
programming (e.g. dispatching web applications based on the URL, generating
URLs for redirects or embedding as links in HTML pages). If you want more
generic URI functionality then you should consider using the L<URI> module.
A URL looks like this:
http://abw@badgerpower.com:8080/under/ground?animal=badger#stripe
\__/ \______________________/\___________/ \___________/ \____/
| | | | |
scheme authority path query fragment
The C<authority> part can be broken down further:
abw@badgerpower.com:8080
\_/ \_____________/ \__/
| | |
user host port
A L<Badger::URL> object will parse a URL and store the component parts
internally. You can then change any of the individual parts and regenerate the
lib/Badger/URL.pm view on Meta::CPAN
You can also specify the individual parts of the URL using named parameters.
my $url = Badger::URL->new(
scheme => 'http',
user => 'abw',
host => 'badgerpower.com',
port => '8080',
path => '/under/ground',
query => 'animal=badger',
fragment => 'stripe',
);
=head2 copy()
This method creates and returns a new C<Badger::URL> object as a copy of
the current one.
my $copy = $url->copy;
=head2 url()
lib/Badger/URL.pm view on Meta::CPAN
Get or set the query parameters.
# get params
my $params = $url->params;
# set params
$url->params(
x => 10
);
=head2 fragment()
Get or set the fragment part of the URL. The leading '#' is not
considered part of the fragment and should be should not be included
when setting a new fragment.
$url->fragment('feet');
print $url->fragment(); # feet
=head2 server()
Returns a composite of the scheme and authority.
print $url->server();
# http://fred@example.org:1234
=head2 service()
Returns a composite of the server (scheme and authority) and path
(in other words, everything up to the query or fragment).
print $url->server();
# http://fred@example.org:1234/right/here
=head2 request()
Returns a composite of the service (scheme, authority and path) and
query (in other words, everything except the fragment).
print $url->request();
# http://fred@example.org:1234/right/here?animal=badger
=head2 relative($path)
Returns a new URL with the relative path specified.
my $base = Badger::URL->new('http://badgerpower.com/example');
my $rel = $base->relative('foo/bar');
lib/Badger/Utils.pm view on Meta::CPAN
};
our $DELEGATES; # fill this from $HELPERS on demand
our $RANDOM_NAME_LENGTH = 32;
our $TEXT_WRAP_WIDTH = 78;
__PACKAGE__->export_any(qw(
UTILS blessed is_object numlike textlike truelike falselike
params self_params plural
odd_params xprintf dotid random_name camel_case CamelCase wrap
permute_fragments plurality inflect split_to_list extend merge merge_hash
list_each hash_each join_uri resolve_uri
));
__PACKAGE__->export_fail(\&_export_fail);
# looks_like_number() is such a mouthful. I prefer numlike() to go with textlike()
*numlike = \&Scalar::Util::looks_like_number;
# it would be too confusing not to have this alias
*CamelCase = \&camel_case;
lib/Badger/Utils.pm view on Meta::CPAN
}
}
push(@lines, join(" ", @line)) if @line;
return join(
"\n" . (' ' x $indent),
@lines
);
}
sub permute_fragments {
my $input = shift;
my (@frags, @outputs);
# Lookup all the (a) optional fragments and (a|b|c) alternate fragments
# replace them with %s. This gives us an sprintf format that we can later
# user to re-fill the fragment slots. Meanwhile create a list of @frags
# with each item corresponding to a (...) fragment which is represented
# by a list reference containing the alternates. e.g. the input
# string 'Fo(o|p) Ba(r|z)' generates @frags as ( ['o','p'], ['r','z'] ),
# leaving $input set to 'Fo%s Ba%s'. We treat (foo) as sugar for (|foo),
# so that 'Template(X)' is permuted as ('Template', 'TemplateX'), for
# example.
$input =~
s/
\( ( .*? ) \)
/
push(@frags, alternates($1));
'%s';
/gex;
# If any of the fragments have multiple values then $format will still contain
# one or more '%s' tokens and @frags will have the same number of list refs
# in it, one for each fragment. To iterate across all permutations of the
# fragment values, we calculate the product P of the sizes of all the lists in
# @frags and loop from 0 to P-1. Then we use a div and a mod to get the right
# value for each fragment, for each iteration. We divide $n by the product of
# all fragment lists to the right of the current fragment and mod it by the size
# of the current fragment list. It's effectively counting with a different base
# for each column. e.g. consider 3 fragments with 7, 3, and 5 values respectively
# [7] [3] [5] P = 7 * 3 * 5 = 105
# [n / 15 % 7] [n / 5 % 3] [n % 5] for 0 < n < P
if (@frags) {
my $product = 1; $product *= @$_ for @frags;
for (my $n = 0; $n < $product; $n++) {
my $divisor = 1;
my @args = reverse map {
my $item = $_->[ $n / $divisor % @$_ ];
$divisor *= @$_;
$item;
} reverse @frags; # working backwards from right to left
push(@outputs, sprintf($input, @args));
}
}
else {
push(@outputs, $input);
}
return wantarray
? @outputs
: \@outputs;
}
lib/Badger/Utils.pm view on Meta::CPAN
$name .= $1.'ies';
}
elsif ($name =~ /([^s\d\W])$/) {
$name .= 's';
}
return $name;
}
sub plurality {
my $n = shift || 0;
my @items = map { permute_fragments($_) }
(@_ == 1 && ref $_[0] eq ARRAY)
? @{ $_[0] }
: @_;
# if the user specifies a single word then we pluralise it for them,
# assuming that 0 items are plural, 1 is singular, and > 1 is plural
if (@items == 1) {
my $plural = plural($items[0]);
unshift(@items, $plural); # 0 whatevers
push(@items, $plural); # n whatevers (where n > 1)
lib/Badger/Utils.pm view on Meta::CPAN
my $url = URL('http://badgerpower.org/example?animal=badger');
print $url->path;
print $url->query;
print $url->server;
=head2 Text Utility Functions
=head3 alternates($text)
This function is used internally by the L<permute_fragments()> function. It
returns a reference to a list containing the alternates split from C<$text>.
alternates('foo|bar'); # returns ['foo','bar']
alternates('foo'); # returns ['','bar']
If the C<$text> doesn't contain the C<|> character then it is assumed to be
an optional item. A list reference is returned containing the empty string
as the first element and the original C<$text> string as the second.
=head3 camel_case($string) / CamelCase($string)
lib/Badger/Utils.pm view on Meta::CPAN
Please note that this function is intentionally limited. It's sufficient to
generate simple headings, summary lines, etc., but isn't intended to be
comprehensive or work in languages other than English.
=head3 numlike($item)
This is an alias to the C<looks_like_number()> function defined in
L<Scalar::Util>.
=head3 permute_fragments($text)
This function permutes any optional or alternate fragments embedded in
parentheses. For example, C<Badger(X)> is permuted as (C<Badger>, C<BadgerX>)
and C<Badger(X|Y)> is permuted as (C<BadgerX>, C<BadgerY>).
permute_fragments('Badger(X)'); # Badger, BadgerX
permute_fragments('Badger(X|Y)'); # BadgerX, BadgerY
Multiple fragments may be embedded. They are expanded in order from left to
right, with the rightmost fragments changing most often.
permute_fragments('A(1|2):B(3|4)') # A1:B3, A1:B4, A2:B3, A2:B4
=head3 plural($noun)
The function makes a very naive attempt at pluralising the singular noun word
passed as an argument.
If the C<$noun> word ends in C<ss>, C<sh>, C<ch> or C<x> then C<es> will be
added to the end of it.
print plural('class'); # classes
lib/Badger/Utils.pm view on Meta::CPAN
for a given number, C<$n>, of a noun, C<$noun> in the English language.
For nouns that pluralise regularly (i.e. via the quick-and-dirty L<plural()>
function), the following is sufficient:
plurality(0, 'package'); # packages
plurality(1, 'package'); # package
plurality(2, 'package'); # packages
For nouns that don't pluralise regularly, or where more complicated phrases
should be constructed, the alternates for 0, 1 and 2 or more items can be
specified in the format expected by L<permute_fragments()>.
plurality($n, 'women|woman|women'); # 0 women, 1 woman, 2 women
plurality($n, 'wo(men|man|men'); # optimised form
=head3 random_name($length,@data)
Generates a random name of maximum length C<$length> using any additional
seeding data passed as C<@args>. If C<$length> is undefined then the default
value in C<$RANDOM_NAME_LENGTH> (32) is used.
lib/Badger/Utils.pm view on Meta::CPAN
foo => 10,
bar => get_the_bar_value() || undef,
);
=head2 URI Utility Functions
The following functions are provided for very simple manipulation of
URI paths. You should consider using the L<URI> module for anything
non-trivial.
=head3 join_uri(frag1, frag2, etc)
Joins the elements of a URI passed as arguments into a single URI.
use Contentity::Utils 'join_uri';
print join_uri('/foo', 'bar'); # /foo/bar
=head3 resolve_uri(base, frag1, frag2, etc)
The first argument is a base URI. The remaining argument(s) are joined
(via L<join_uri()>) to construct a relative URI. If the relative URI begins
with C</> then it is considered absolute and is returned unchanged. Otherwise
it is appended to the base URI.
use Contentity::Utils 'resolve_uri';
print resolve_uri('/foo', 'bar/baz'); # /foo/bar/baz
print resolve_uri('/foo', '/bar/baz'); # /bar/baz
pod/Badger/Changes.pod view on Meta::CPAN
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
is set (e.g. for Pod coverage/kwalitee tests that you only want to run
if either of the C<RELEASE_TESTING> or C<AUTOMATED_TESTING> environment
variables is set).
Added the L<random_name()|Badger::Utils/random_name()>,
L<camel_case()|Badger::Utils/camel_case()> and
L<permute_fragments()|Badger::Utils/permute_fragments()> functions to
L<Badger::Utils>. Also add some extra debugging code to
L<params()|Badger::Utils/params()> and
L<self_params()|Badger::Utils/self_params()> to catch any attempt to pass an
odd number of arguments.
Changed the L<Badger::Factory> module to use
L<permute_fragments()|Badger::Utils/permute_fragments()> on the module path
when specified as a single string. Also added the
L<default()|Badger::Factory/default()> and
L<names()|Badger::Factory/names()> methods along with their corresponding
package variable magic.
Added the L<debug_callers()|Badger::Debug/debug_callers()>,
L<debugf()|Badger::Debug/debugf()> and L<debug_at()|Badger::Debug/debug_at()>
methods to L<Badger::Debug>.
Added the L<alias()|Badger::Class/alias()> method to
t/core/url.t view on Meta::CPAN
# test accessors to read various parts of the URL
#------------------------------------------------------------------------
is( $url->scheme, $SCHEME, "scheme is $SCHEME" );
is( $url->authority, $AUTHORITY,"authority is $AUTHORITY" );
is( $url->user, $USER, "user is $USER" );
is( $url->host, $HOST, "host is $HOST" );
is( $url->port, $PORT, "port is $PORT" );
is( $url->path, $PATH, "path is $PATH" );
is( $url->query, $QUERY, "query is $QUERY" );
is( $url->fragment, $FRAGMENT, "fragment is $FRAGMENT" );
is( $url->server, $SERVER, "server is $SERVER" );
is( $url->service, $SERVICE, "service is $SERVICE" );
is( $url->request, $REQUEST, "request is $REQUEST" );
my $params = $url->params;
ok( $params, 'got params' );
is( $params->{ animal }, 'badger', 'animal is a badger' );
my $copy = $url->copy;
ok( $copy, 'got a copy' );
t/core/url.t view on Meta::CPAN
'changed port' );
is( $copy->path('/right/here'), '/right/here', 'set path to /right/here' );
is( $copy, "ftp://ferret\@example.com:1234/right/here?$QUERY#$FRAGMENT",
'changed path' );
is( $copy->query('animal=ferret'), 'animal=ferret', 'set query to animal=ferret' );
is( $copy, "ftp://ferret\@example.com:1234/right/here?animal=ferret#$FRAGMENT",
'changed query' );
is( $copy->fragment('feet'), 'feet', 'set fragment to feet' );
is( $copy, "ftp://ferret\@example.com:1234/right/here?animal=ferret#feet",
'changed fragment' );
#-----------------------------------------------------------------------
# test relative URLs
#-----------------------------------------------------------------------
is( $url->relative('foo'),
"$SERVER/over/there/foo?$QUERY#$FRAGMENT",
'set relative path: foo'
);
t/core/url.t view on Meta::CPAN
# test constructor with separate elements
#-----------------------------------------------------------------------
$url = URL->new(
scheme => 'http',
user => 'Mr.T',
host => 'badgerpower.com',
port => '8081',
path => '/somewhere/else',
query => 'animal=badger',
fragment => 'stripe',
);
ok( $url, 'created url from params' );
is( $url->authority, 'Mr.T@badgerpower.com:8081', 'got params authority' );
is( $url->server, 'http://Mr.T@badgerpower.com:8081', 'got params server' );
is( $url->service, 'http://Mr.T@badgerpower.com:8081/somewhere/else', 'got params service' );
is( $url->request, 'http://Mr.T@badgerpower.com:8081/somewhere/else?animal=badger', 'got params request' );
$url = URL->new('http://badgerpower.com/');
t/core/utils.t view on Meta::CPAN
# This is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
#========================================================================
use strict;
use warnings;
use lib qw( t/core/lib ./lib ../lib ../../lib );
use Badger::Debug modules => 'Badger::Utils';
use Badger::Utils 'UTILS blessed xprintf reftype textlike plural permute_fragments';
use Badger::Test
tests => 118,
debug => 'Badger::Utils',
args => \@ARGV;
is( UTILS, 'Badger::Utils', 'got UTILS defined' );
ok( blessed bless([], 'Wibble'), 'got blessed' );
#-----------------------------------------------------------------------
t/core/utils.t view on Meta::CPAN
"camel_case('FOO_bar') => 'FOOBar'"
);
is( CamelCase('hello_world'), 'HelloWorld',
"CamelCase('hello_world') => 'HelloWorld'"
);
#-----------------------------------------------------------------------
# test permute_fragments()
#-----------------------------------------------------------------------
test_permute('foo', 'foo');
test_permute('Template(X)', 'Template', 'TemplateX');
test_permute('Template(X|)', 'TemplateX', 'Template');
test_permute(
'Template(X)::(XS::TT3|TT3)::Foo',
'Template::XS::TT3::Foo',
'Template::TT3::Foo',
'TemplateX::XS::TT3::Foo',
'TemplateX::TT3::Foo',
);
sub test_permute {
my $input = shift;
my @outputs = permute_fragments($input);
# print(" INPUT: $input\n");
# print("OUTPUTS: ", join(', ', @outputs), "\n");
foreach my $output (@outputs) {
if (@_) {
my $expect = shift;
is( $output, $expect, "$input => $expect" );
}
else {
fail("$input permuted unexpected value: $output");
( run in 1.724 second using v1.01-cache-2.11-cpan-364913b4093 )