view release on metacpan or  search on metacpan

lib/Acme/BooK/Is/My/Bitch.pm  view on Meta::CPAN

package Acme::BooK::Is::My::Bitch;
$Acme::BooK::Is::My::Bitch::VERSION = '0.05';
use 5.006;
use warnings;
use strict;

use Acme::MetaSyntactic;

# ###### Implementation ###########

sub new { shift }

my $de_underscore = sub { map { y/_/ /; $_ } @_ };

my %methods = (
    'tell_the_truth' => [
        'You know, my favorite pornstar is definitely %s.',
        'pornstars', $de_underscore
    ],
    'thats_nothing' => [
        'Oh, that\'s nothing! You should\'ve seen what I auctioned in %s!',
        'yapc', $de_underscore
    ],
    'code' => [
        'You know, I wrote some code for the %s space mission, but it was rejected for its lack of clarity...',
        'space_missions', $de_underscore
    ],
    'next_talk' => [
        'My next lightning talk will be called "%s! %s!! %s!!!"',
        'batman', sub { map { y/_/-/; ucfirst } @_ }
    ],
    'next_yapc' => [
         'I think the next YAPC should be on %s!',
         'planets', ],
    'sql' => [
         'I think we can solve that with a %s %s %s',
         'sql', ],
    'twisted_perl' => [
        'I\'m pretty sure I could do that just by using %s and %s',
        'opcodes',
    ],
    'words_of_wisdom' => [
        'My grandfather once told me:' . ' %s' x 7,
        'loremipsum',
    ],
    ( # quotes that need a theme/category
        'baby_girl' => [
            'You know we considered naming our baby girl %s?',
            'pornstars/female',
            sub { ( my $baby = shift ) =~ s/_.*$//; $baby }
        ],
        meeting_room => [
            'I think this meeting room should be called %s',
            [ 'barbapapa/nl', 'barbapapa/en' ],
        ],
        favourite_colour => [
            'My favourite colour is %s',
            [ 'colours/en', 'colours/x-11' ],
            sub { my $colour = shift; return $colour =~ /pink|rose/i ? $de_underscore->( $colour ) : (); }
        ]
    )x!! ( $Acme::MetaSyntactic::VERSION >= 1.011 ),
);

for my $method ( keys %methods ) {
    my ( $template, $theme, $filter ) = @{ $methods{$method} };
    $filter ||= sub {@_};
    my $qty =()= $template =~ /%s/g;
    no strict 'refs';
    *{$method} = sub {
        my $th = ref $theme ? $theme->[rand @$theme] : $theme;
        my @args;
        @args = $filter->( metaname( $th => $qty ) ) while !@args;
        return sprintf $template, @args;
    };
}

sub available_quotes { return sort keys %methods }

sub random_quote {
    my $self = shift;
    my $method  = (keys %methods)[ rand keys %methods ];
    return $self->$method();
}

1;    # Magic true value required at end of module

=pod

=encoding iso-8859-1

=head1 NAME

Acme::BooK::Is::My::Bitch - BooK is my Bitch

=head1 VERSION

version 0.05

=head1 SYNOPSIS

    use Acme::BooK::Is::My::Bitch;

    my $bitch = Acme::BooK::Is::My::Bitch->new();

    my $quote = $bitch->random_quote();

=head1 DESCRIPTION

Acme::BooK::Is::My::Bitch has a great story behind it.

At YAPC::EU::2006, in Birmingham, England, BooK auctioned the right
for someone to pick a module from CPAN and have that module's name
(temporarily) tattoed in his arm for all the conferences BooK would go
to during 2007.

Cog asked if the module had to exist by that time, and BooK said "No."

BIG MISTAKE!

=head1 INTERFACE

=head2 Program Interface

=head3 new

Creates a new Acme::BooK::Is::My::Bitch object.

    my $bitch = Acme::BooK::Is::My::Bitch->new();

Since all methods are actually class methods, the following line
is exactly equivalent to the above one (and shorter!):

    my $bitch = 'Acme::BooK::Is::My::Bitch';

=head3 available_quotes

Returns the list of available quote methods.

=head2 Module Interface