view release on metacpan or  search on metacpan

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

#=========# INTERNAL FUNCTION
#
#   $string = _join_local(@_);     # short
#       
# Purpose   : Like builtin join() but with local list separator.
# Parms     : @_        : strings to join
# Returns   : $string   : joined strings
# Throws    : ____
# See also  : init()
# 
# Buitin join() does not take $" (or anything else) by default.
# We splice out empty strings to avoid useless runs of spaces.  
# 
sub _join_local {
    my @parts       = @_;
    
    # Splice out empty strings. 
   @parts       = grep { $_ ne q** } @parts;
    
    return join $", @parts;
}; ## _join_local

#=========# INTERNAL FUNCTION
#
#   my %args    = _paired(@_);     # check for unpaired arguments
#       
# Purpose   : ____
# Parms     : ____
# Reads     : ____
# Returns   : ____
# Writes    : ____
# Throws    : ____
# See also  : ____
# 
# ____
#   
sub _paired {
    if ( scalar @_ % 2 ) {  # an odd number modulo 2 is one: true
        die 'Error::Base internal error: unpaired args';
    };
    return @_;
}; ## _paired

#=========# CLASS METHOD
#
#   my $obj     = $class->new();
#   my $obj     = $class->new({ -a  => 'x' });
#       
# Purpose   : Object constructor
# Parms     : $class    : Any subclass of this class
#             anything else will be passed to init()
# Returns   : $self
# Invokes   : init()
# 
# Good old-fashioned hashref-based object constructor. 
# 
sub new {
    my $class   = shift;
    my $self    = {};           # always hashref
    
    bless ($self => $class);
    $self->init(@_);            # init remaining args
    
    return $self;
}; ## new

#=========# OBJECT METHOD
#
#   $err->init(        k => 'v', f => $b );
#   $err->init( $text, k => 'v', f => $b );
#
# An object can be init()-ed more than once; all new values overwrite the old.
# This non-standard init() allows an unnamed initial arg. 
#
# See: crash()
#
sub init {
    my $self        = shift;
    if ( scalar @_ % 2 ) {              # an odd number modulo 2 is one: true
        $self->{-mesg}  = shift;        # and now it's even
    };
    
    # Merge all values. Newer values always overwrite. 
    %{$self}        = ( %{$self}, @_ );
    
    # Set some default values, mostly to avoid 'uninitialized' warnings.
    $self->put_base(  $self->{-base}  );
    $self->put_type(  $self->{-type}  );
    $self->put_mesg(  $self->{-mesg}  );
    $self->put_quiet( $self->{-quiet} );
    $self->put_nest(  $self->{-nest}  );
    $self->_fix_pre_ind();
    
    return $self;
}; ## init

#----------------------------------------------------------------------------#
# ACCSESSORS

my $Default = {
    -base           =>  q{},
    -type           =>  q{},
    -mesg           =>  q{},
    -quiet          =>  0,
    -nest           =>  0,
    -prepend        =>  undef,
    -indent         =>  undef,
};



# put
sub put_base {
    my $self            = shift;
    $self->{-base}      = shift;
    if    ( not defined $self->{-base}  ) {
        $self->{-base}  = $Default->{-base};
    };
    return $self;
};
sub put_type {