view release on metacpan or  search on metacpan

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

    # _format
    #   Format the message's "output" attribute ready for issue.
    sub _format
    {
        my ( $message, @args ) = @_;
        my $txt = '';
        $txt .= $message->_message_timestamp_text
            if $message->_type_timestamp( $message->type );
        $txt .= $message->_message_tlc_text
            if $message->_type_tlc( $message->type );
        $txt .= $message->_message_id_text
            if $message->_type_id( $message->type );
        if ( @args ) {
            $txt .= sprintf( $message->{template}, @args );
        }
        else {
            $txt .= $message->{template};
        }
        $message->output( $txt );
        return $message;
    }

    # _message_timestamp_text
    #   Returns the text used to represent time in the message's output.
    sub _message_timestamp_text
    {
        my ( $message )      = @_;
        my $timestamp_format = $message->_type_timestamp( $message->type );
        my $time             = DateTime->now;
        return $time->strftime( $message->_default_timestamp_format ) . ' '
            if $timestamp_format eq '1';
        return $time->strftime( $timestamp_format ) . ' ';
    }

    # _message_tlc_text
    #   Returns the text used to represent three-letter type code in the
    #   message's output.
    sub _message_tlc_text
    {
        my ( $message ) = @_;
        my $tlc = $message->_type_tlc( $message->type );
        return sprintf( '*%s* ', uc( $tlc ) );
    }

    # _prepend_message_id
    #   Returns the text used to represent the identity of the message
    #   being output.
    sub _message_id_text
    {
        my ( $message ) = @_;
        return sprintf( '%s ', uc( $message->id ) );
    }

    # id
    #   Set or get the message's identity. The identity must be a valid Perl
    #   subroutine identifier.

    my %bad_identifiers = map +( $_, 1 ), qw/
        BEGIN       INIT        CHECK       END         DESTROY
        AUTOLOAD    STDIN       STDOUT      STDERR      ARGV
        ARGVOUT     ENV         INC         SIG         UNITCHECK
        __LINE__    __FILE__    __PACKAGE__ __DATA__    __SUB__
        __END__     __ANON__
        /;

    sub id
    {
        my ( $message, $value ) = @_;
        return $message->{id}
            unless @_ > 1;
        my $short_types = $message->_message_types;
        my $type;
        if ( $value =~ m{(^.+):([${short_types}])$} ) {
            ( $value, $type ) = ( $1, $2 );
        }
        C_BAD_MESSAGE_ID( $value )
            unless $value && $value =~ /^[\p{Alpha}_\-][\p{Digit}\p{Alpha}_\-]*$/;
        C_BAD_MESSAGE_ID( $value )
            if exists $bad_identifiers{$value};
        if ( $message->_update_type_on_id_change ) {
            if ( $type ) {
                $message->type( $type );
            }
            else {
                if ( $value =~ /[_\d]([${short_types}])$/ ) {
                    $message->type( $1 );
                }
                elsif ( $value =~ /^([${short_types}])[_\d]/ ) {
                    $message->type( $1 );
                }
                else {
                    my %long_types = $message->_types_by_alias;
                    my $long_types = join '|',
                        sort { length( $b ) <=> length( $a ) } keys %long_types;
                    if ( $value =~ /(${long_types})$/ ) {
                        $message->type( $long_types{$1} );
                    }
                    elsif ( $value =~ /^(${long_types})/ ) {
                        $message->type( $long_types{$1} );
                    }
                    else {
                        $message->type( 'M' );
                    }
                }
            }
        }
        $message->{id} = $value;
        return $message;
    } ## end sub id
} ## end BEGIN

# _export_messages
#   Oversees the injection of message issuers into the target namespace.
#
#   If messages are organised into one or more tag groups, then this method
#   also ensuring that the target namespace is an Exporter before updating
#   the @EXPORT_OK, %EXPORT_TAGS in that namespace with details of the
#   messages being injected. To be clear, messages must be grouped before
#   this method stomps over the target namespace's @ISA, @EXPORT_OK, and
#   %EXPORT_TAGS.
#