view release on metacpan or  search on metacpan

lib/Badger/Base.pm  view on Meta::CPAN

#-----------------------------------------------------------------------

sub message {
    my $self   = shift;
    my $name   = shift
        || $self->fatal("message() called without format name");
    my $ref    = $self && reftype $self;
    my $format;

    # allow $self object to have an internal messages hash
    if ($self && $ref && $ref eq HASH && $self->{ messages }) {
        $format = $self->{ messages }->{ $name }
            if reftype $self->{ messages } eq HASH;
    }

    $format = class($self)->hash_value( MESSAGES => $name )
        || $self->fatal("message() called with invalid message type: $name")
            unless defined $format;

    xprintf($format, @_);
}

sub warn_msg {
    # explicitly quantify local message() method in case a subclass decides
    # to re-implement the message() method to do something else
    $_[0]->warn( message(@_) );
}

sub error_msg {
    $_[0]->error( message(@_) );
}

sub fatal_msg {
    $_[0]->fatal( message(@_) );
}

sub decline_msg {
    $_[0]->decline( message(@_) );
}

sub debug_msg {
    $_[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 = $_;
        my $ON_EVENT = uc $on_event;

        $on_event => sub {
            my $self  = shift;
            my $class = class($self);
            my $list;

            if (ref $self && reftype $self eq HASH) {
                # look in $self->{ config }->{ on_xxx } or in $ON_XXX pkg
                # var for one or more event handlers
                $list = $self->{ $ON_EVENT }
                    ||= $self->{ config }->{ $on_event }
                    ||  $class->list_vars($ON_EVENT);
                # careful!  the config value might be a single handler
                $list = $self->{ $ON_EVENT } = [$list]
                    unless ref $list eq ARRAY;
                $self->debug("got $on_event handlers: ", $self->dump_data_inline($list), "\n") if DEBUG;
            }
            else {
                # class method or non-hash objects use pkg vars only
                $list = $class->var_default($ON_EVENT, []);
                $list = $class->var($ON_EVENT, [$list])
                    unless ref $list eq ARRAY;
            }

            # Add to the list any extra handlers passed as args.  First
            # argument can be 'before' or 'after' to add remaining args
            # to start or end of list, otherwise the entire list is replaced.
            if (@_) {
                if ($_[0] eq before) {
                    shift;
                    unshift(@$list, @_);
                }
                elsif ($_[0] eq after) {
                    shift;
                    push(@$list, @_);
                }
                else {
                    @$list = @_;
                }
            }
            # push(@$list, @_);

            return $list;