view release on metacpan or  search on metacpan

lib/Message/String.pm  view on Meta::CPAN

            $type = uc( $type );
            if ( @_ > 2 ) {
                $value ||= '';
                $value = substr( $value, 0, 3 )
                    if length( $value ) > 3;
                $types->{$type}{tlc} = $value;
                return $invocant;
            }
            return $types->{$type}{tlc}
                if exists $types->{$type};
        }
        return undef;
    }

    # _type_aliases
    #   Inspect or change the "aleiases" setting for a message type.
    # * Be careful when calling this as an instance method as copy-on-
    #   write semantics come into play (see "_types" for more information).
    sub _type_aliases
    {
        my ( $invocant, $type, $value ) = @_;
        if ( @_ > 1 && defined( $type ) ) {
            my $types = $invocant->_types( @_ > 2 );
            $type = uc( $type );
            if ( @_ > 2 ) {
                my $tlc = $invocant->_type_tlc( $type );
                $value = []
                    unless $value;
                $value = [$value]
                    unless ref $value;
                $types->{$type}{aliases} = $value;
                return $invocant;
            }
            if ( exists $types->{$type} ) {
                return @{ $types->{$type}{aliases} } if wantarray;
                return $types->{$type}{aliases};
            }
        }
        return wantarray ? () : undef;
    }

    # _types_by_alias
    #   In list context, returns a hash of aliases and their correspondin
    #   message type codes.
    sub _types_by_alias
    {
        my ( $invocant ) = @_;
        my $types = $invocant->_types;
        my %long_types;
        for my $type ( keys %$types ) {
            %long_types
                = ( %long_types, map { $_ => $type } @{ $types->{$type}{aliases} } );
            $long_types{ $types->{$type}{tlc} } = $type
                if $types->{$type}{tlc};
        }
        return wantarray ? %long_types : \%long_types;
    }

    # _update_type_on_id_change
    #   Check or change whether or not message types are set automatically
    #   when message ids are set. The cascade is enabled by default.
    my $auto_type = 1;

    sub _update_type_on_id_change
    {
        my ( $invocant, $value ) = @_;
        return $auto_type
            unless @_ > 1;
        $auto_type = !!$value;
        return $invocant;
    }

    my $auto_level = 1;

    # _update_level_on_type_change
    #   Check or change whether or not message levels are set automatically
    #   when message types are set. The cascade is enabled by default.
    sub _update_level_on_type_change
    {
        my ( $invocant, $value ) = @_;
        return $auto_level
            unless @_ > 1;
        $auto_level = !!$value;
        return $invocant;
    }

    # _minimum_verbosity
    #   Returns the minimum verbosity level, always the same level as
    #   error messages.
    my $min_verbosity = __PACKAGE__->_type_level( 'E' );

    sub _minimum_verbosity {$min_verbosity}

    # _verbosity
    #   Returns the current verbosity level, which is greater than or
    #   equal to the severity level of all messages to be issued.
    my $cur_verbosity = __PACKAGE__->_type_level( 'D' );

    sub verbosity
    {
        my ( $invocant, $value ) = @_;
        return $cur_verbosity
            unless @_ > 1;
        if ( $value =~ /^\d+$/ ) {
            $cur_verbosity = 0 + $value;
        }
        else {
            my $types = $invocant->_types;
            $value = uc( $value );
            if ( length( $value ) > 1 ) {
                my $long_types = $invocant->_types_by_alias;
                $value = $long_types->{$value} || 'D';
            }
            $value = $types->{$value}{level}
                if index( $invocant->_message_types, $value ) > -1;
            $cur_verbosity = 0 + ( $value || 0 );
        }
        $cur_verbosity = $min_verbosity
            if $cur_verbosity < $min_verbosity;
        return $invocant;
    }

    # _default_timestamp_format
    #   Check or change the default timestamp format.
    my $timestamp_format = '%a %x %T';

    sub _default_timestamp_format
    {
        my ( $invocant, $value ) = @_;
        return $timestamp_format
            unless @_ > 1;
        $timestamp_format = $value || '';
        return $invocant;
    }

    # _alert
    #   The handler used by the message issuer ("issue") to deliver