File Coverage

blib/lib/Mail/Alias/Reader/Token.pm

Criterion	Covered	Total	%
statement	76	76	100.0
branch	18	18	100.0
condition			n/a
subroutine	23	23	100.0
pod	6	12	50.0
total	123	129	95.3

# Copyright (c) 2012, cPanel, Inc.
# All rights reserved.
# http://cpanel.net/
#
# This is free software; you can redistribute it and/or modify it under the same
# terms as Perl itself.  See the LICENSE file for further details.

package Mail::Alias::Reader::Token;

use strict;
use warnings;

use Carp;

=head1 NAME

Mail::Alias::Reader::Token

=head1 DESCRIPTION

Mail::Alias::Reader::Token is not only the class represents an aliases(5) parser
token, but also itself is returned by L as a representation
of a mail alias destination.  For the purposes of this documentation, only the
public-facing methods which facilitate the usage of instances of this class
shall be discussed.

=cut

my @TOKEN_TYPES = (
    [ 'T_COMMENT'    => qr/#\s*(.*)$/ ],
    [ 'T_STRING'     => qr/("(?:\\.|[^"\\]+)*")/ ],
    [ 'T_COMMA'      => qr/,/ ],
    [ 'T_DIRECTIVE'  => qr/:([^\:\s]+):([^\:\s,]*)/ ],
    [ 'T_COMMAND'    => qr/\|(\S+)/ ],
    [ 'T_ADDRESS'    => qr/([a-z0-9_\-@\.*]+)/i ],
    [ 'T_COLON'      => qr/\:/ ],
    [ 'T_FILE'       => qr/(\S+)/ ],
    [ 'T_WHITESPACE' => qr/\s+/ ],
);

my @TOKEN_STRING_TYPES = (
    [ 'T_DIRECTIVE' => qr/:([^\:\s]+):\s*(.*)/s ],
    [ 'T_COMMAND'   => qr/\|(.*)/s ],
    [ 'T_ADDRESS'   => qr/([^\/]+)/s ],
    [ 'T_FILE'      => qr/(.*)/s ]
);

#
# Mail::Alias::Reader::Token->new($type)
#
# Create a new mail alias parser token of the given type.  This method isn't
# actually meant to be called publically; rather, it is simply a shortcut to
# create symbolic parser tokens that contain no data, but refer to a piece of
# punctuation, or similar.
#
sub new {
    my ( $class, $type ) = @_;

    return bless { 'type' => $type }, $class;
}

#
# $token->isa(@types)
#
# Return true if the current token is of any of the types passed as an
# argument.
#
sub isa {
    my ( $self, @types ) = @_;

    foreach my $type (@types) {
        return 1 if $self->{'type'} eq $type;
    }

    return 0;
}

#
# $token->is_punct()
#
# Returns true if the current token represents a piece of punctuation, or
# something that separates values, clauses, or declarations from one another.
#
sub is_punct {
    return shift->isa(qw/T_BEGIN T_END T_COLON T_COMMA/);
}

#
# $token->is_value()
#
# Returns true if the current token represents a meaningful value recorded in
# text, such as a mail transfer agent directive, a command to pass message to,
# a local or remote mailing address, or a file to append messages to.
#
sub is_value {
    return shift->isa(qw/T_DIRECTIVE T_COMMAND T_ADDRESS T_FILE/);
}

=head1 DETERMINING MAIL DESTINATION TYPE

A variety of methods are provided to allow one to infer the type of a mail
alias (parser token) returned.

=over

=item $destination->is_address()

Returns true if the mail destination described by the current token is a local
part or fully qualified mail address.

=cut

sub is_address {
    return shift->isa('T_ADDRESS');
}

=item $destination->is_directive()

Returns true if the mail destination described by the current token is a
mail transfer agent directive.

=cut

sub is_directive {
    return shift->isa('T_DIRECTIVE');
}

=item $destination->is_command()

Returns true if the mail destination described by the current token is a
command to which mail messages should be piped.

=cut

sub is_command {
    return shift->isa('T_COMMAND');
}

=item $destination->is_file()

Returns true if the mail destination described by the current token is a file
to which mail messages should be appended.

=back

=cut

sub is_file {
    return shift->isa('T_FILE');
}

=head1 CONVERTING THE MAIL DESTINATION TO A STRING

=over

=item $destination->value()

Returns a parsed and unescaped logical representation of the mail alias
destination that was originally parsed to yield the current token object.

=cut

sub value {
    return shift->{'value'};
}

=item $destination->to_string()

Returns a string representation of the mail alias destination that was
originally parsed to yield the current token object.

=back

=cut

sub to_string {
    my ($self) = @_;

    my %SUBSTITUTIONS = (
        "\r" => '\r',
        "\n" => '\n',
        "\t" => '\t',
        '"'  => '\"'
    );

    my $value = $self->{'value'};

    if ($value) {
        foreach my $search ( keys %SUBSTITUTIONS ) {
            $value =~ s/$search/$SUBSTITUTIONS{$search}/g;
        }
    }

    #
    # Since not every token type has a "value", per se, lazy evaluation is
    # necessary to prevent a Perl runtime warning when evaluating the 'T_COMMENT'
    # part of this hash when dealing with tokens that are anything other than a
    # comment.
    #
    my %FORMATTERS = (
        'T_COMMENT'    => sub { "# $value" },
        'T_COMMA'      => sub { ',' },
        'T_COLON'      => sub { ':' },
        'T_WHITESPACE' => sub { ' ' }
    );

    return $FORMATTERS{ $self->{'type'} }->() if exists $FORMATTERS{ $self->{'type'} };

    my $ret;

    if ( $self->is_directive ) {
        $ret = ":$self->{'name'}:$value";
    }
    elsif ( $self->is_command ) {
        $ret = "|$value";
    }
    else {
        $ret = $value;
    }

    #
    # If the data to be returned contains spaces, then wrap it with double quotes
    # before returning it to the user.
    #
    $ret =~ s/^(.*)$/"$1"/ if $ret =~ /\s/;

    return $ret;
}

#
# Mail::Alias::Reader::Token->tokenize_for_types($buf, @types)
#
# Transform the given text buffer, $buf, into a series of tokens, based on the
# rules passed in @types (defined near the top of this file).  Returns an ARRAY
# of tokens that were matched based on the rules in @types versus the input
# buffer.
#
# As the token types are associated with their parsing rules, and are given in
# an ordered manner, proper precedence can be followed and ambiguity in lexing
# can be overcome.
#
# This method does not provide the main tokenizing interface; rather, it only
# facilitates for the easy access of a single pass of tokenizing, and is called
# by the Mail::Alias::Reader::Token->tokenize() method.
#
sub tokenize_for_types {
    my ( $class, $buf, @types ) = @_;
    my @tokens;

  match: while ($buf) {
        foreach my $type (@types) {
            next unless $buf =~ s/^$type->[1]//;

            my $token = bless {
                'type' => $type->[0],
            }, $class;

            if ( $type->[0] eq 'T_DIRECTIVE' ) {
                @{$token}{qw(name value)} = ( $1, $2 );
            }
            else {
                $token->{'value'} = $1;
            }

            push @tokens, $token;

            next match;
        }
    }

    return \@tokens;
}

#
# Mail::Alias::Reader::Token->tokenize($buf)
#
# Returns an ARRAY of tokens parsed from the given text buffer.
#
# This method tokenizes in two stages; first, it performs a high-level sweep of
# any statements not inside double quotes, though while grabbing double-quoted
# statements and holding onto them for a later second pass.  During this second
# tokenization pass, performed for each double-quoted statement found and in the
# order of first-stage tokenization, statements containing spaces are parsed.
#
# Since this method is intended to be used on a single line of input, a T_BEGIN
# and T_END token comes as the first and the last token returned, respectively.
#
sub tokenize {
    my ( $class, $buf ) = @_;

    #
    # When parsing token data contained within double quotes, the following
    # escape sequence patterns and substitutions are iterated over for each
    # double quoted expression, performing unescaping where necessary.
    #
    my %WHITESPACE = (
        'r' => "\r",
        'n' => "\n",
        't' => "\t"
    );

    my @STRING_ESCAPE_SEQUENCES = (
        [ qr/\\(0\d*)/       => sub { pack 'W', oct($1) } ],
        [ qr/\\(x[0-9a-f]+)/ => sub { pack 'W', hex("0$1") } ],
        [ qr/\\([rnt])/      => sub { $WHITESPACE{$1} } ],
        [ qr/\\([^rnt])/     => sub { $1 } ]
    );

    #
    # Perform first stage tokenization on the input.
    #
    my $tokens = $class->tokenize_for_types( $buf, @TOKEN_TYPES );

    foreach my $token ( @{$tokens} ) {

        #
        # Perform second stage tokenization on any T_STRING tokens found.  As the aliases(5)
        # format lacks a string literal type, a second pass is required to parse the quote
        # delimited string out for a more specific type.
        #
        if ( $token->isa('T_STRING') ) {
            $token->{'value'} =~ s/^"(.*)"$/$1/s;

            #
            # Parse for any escape sequences that may be present.
            #
            foreach my $sequence (@STRING_ESCAPE_SEQUENCES) {
                my ( $pattern, $subst ) = @{$sequence};

                $token->{'value'} =~ s/$pattern/$subst->()/seg;
            }

            #
            # Create a new token from the second pass parsing step for the string
            # contents, copying the data directly into the existing token (so as to
            # not lose the previous reference).
            #
            %{$token} = %{ $class->tokenize_for_types( $token->{'value'}, @TOKEN_STRING_TYPES )->[0] };
        }
    }

    return [
        $class->new('T_BEGIN'),
        @{$tokens},
        $class->new('T_END')
    ];
}

1;

__END__