File Coverage

blib/lib/Parse/HTTP/UserAgent.pm

Criterion	Covered	Total	%
statement	177	206	85.9
branch	110	134	82.0
condition	42	62	67.7
subroutine	19	21	90.4
pod	3	3	100.0
total	351	426	82.3

package Parse::HTTP::UserAgent;
$Parse::HTTP::UserAgent::VERSION = '0.41';
use strict;
use warnings;

use base qw(
    Parse::HTTP::UserAgent::Base::IS
    Parse::HTTP::UserAgent::Base::Parsers
    Parse::HTTP::UserAgent::Base::Dumper
    Parse::HTTP::UserAgent::Base::Accessors
);

use overload '""',    => 'name',
             '0+',    => 'version',
             fallback => 1,
;

use version;
use Carp qw( croak );
use Parse::HTTP::UserAgent::Constants qw(:all);

BEGIN {
    constant->import( DEBUG => 0 ) if not defined &DEBUG;
}

my %OSFIX = (
    'WinNT4.0'       => 'Windows NT 4.0',
    'WinNT'          => 'Windows NT',
    'Windows 4.0'    => 'Windows 95',
    'Win95'          => 'Windows 95',
    'Win98'          => 'Windows 98',
    'Windows 4.10'   => 'Windows 98',
    'Win 9x 4.90'    => 'Windows Me',
    'Windows NT 5.0' => 'Windows 2000',
    'Windows NT 5.1' => 'Windows XP',
    'Windows XP 5.1' => 'Windows XP', # huh?
    'Windows NT 5.2' => 'Windows Server 2003',
    'Windows NT 6.0' => 'Windows Vista / Server 2008',
    'Windows NT 6.1' => 'Windows 7',
    'Windows NT 6.2' => 'Windows 8',
    'Windows NT 6.3' => 'Windows 8.1',
);

sub new {
    my $class = shift;
    my $ua    = shift || croak 'No user agent string specified';
    my $opt   = shift || {};
    croak 'Options must be a hash reference' if ref $opt ne 'HASH';
    my $self  = [ map { undef } 0..MAXID ];
    bless $self, $class;
    @{ $self }[ UA_STRING, UA_STRING_ORIGINAL ] = ($ua) x 2;
    $self->[IS_EXTENDED] = exists $opt->{extended} ? $opt->{extended} : 1;
    $self->_normalize( $opt->{normalize} ) if $opt->{normalize};
    $self->_parse;
    return $self;
}

sub as_hash {
    my $self = shift;
    my %struct;
    foreach my $id ( $self->_object_ids ) {
        (my $name = $id) =~ s{ \A UA_ }{}xms;
        $struct{ lc $name } = $self->[ $self->$id() ];
    }
    return %struct;
}

sub trim {
    my $self = shift;
    my $s    = shift;
    return $s if ! $s;
    $s =~ s{ \A \s+    }{}xms;
    $s =~ s{    \s+ \z }{}xms;
    return $s;
}

sub _normalize {
    my $self = shift;
    my $nopt = shift;
    my $type = ref $nopt;

    my @o = ! $type            ? ':all'
          :   $type eq 'ARRAY' ? @{ $nopt }
          :                      croak "Normalization option $nopt is invalid";

    my %mode      = map { $_ => 1 } @o;
    my @all       = qw( plus_to_space trim_spaces );
    @mode{ @all } = (1) x @all if delete $mode{':all'};

    my $s = \$self->[UA_STRING];
    ${$s} =~ s{[+]}{ }xmsg if $mode{plus_to_space};
    ${$s} =~ s<\s+>< >xmsg if $mode{trim_spaces};
    return;
}

sub _parse {
    my $self = shift;
    return $self if $self->[IS_PARSED];
    $self->_do_parse( $self->_pre_parse );
    $self->[IS_PARSED] = 1;
    $self->_post_parse if ! $self->[UA_UNKNOWN];
    return;
}

sub _pre_parse {
    my $self  = shift;
    my $ua    = $self->[UA_STRING];
    my $uc_ua = uc $ua;

    $self->[IS_MAXTHON] = index($uc_ua, 'MAXTHON')  != NO_IMATCH;
    $self->[IS_TRIDENT] = index($uc_ua, 'TRIDENT/') != NO_IMATCH;

    my @parts;
    my $i     = 0;
    my $depth = 0;

    foreach my $token ( split RE_SPLIT_PARSE, $ua ) {
        if ( $token eq '(' ) {
            $i++ if ++$depth == 1;
            next;
        }
        if ( $token eq ')' ) {
            $i++ if --$depth == 0;
            next;
        }
        push @{ $parts[$i] ||= [] }, $token;
    }

    # Hopefully the above code was successful and now we can set the actual
    # tokens to use inside parsers.
    my($moz)    = join ' ', @{ shift(@parts) || []  };
    my($thing)  = join ' ', @{ shift(@parts) || []  };
    my($extra)  = join ' ', @{ shift(@parts) || []  };
    my(@others) = map { @{ $_ } } @parts;

    $thing = $thing ? [ split RE_SC_WS, $thing ] : [];
    $extra = [ split RE_WHITESPACE, $extra ] if $extra;

    $self->_debug_pre_parse( $moz, $thing, $extra, @others ) if DEBUG;
    return $moz, $thing, $extra, @others;
}

sub _do_parse {
    my($self, $m, $t, $e, @o) = @_;

    my $c = $t->[0] && $t->[0] eq 'compatible';

    if ( $c
        && shift @{$t}                     # just inline removal of "compatible"
        && ( ! $e || $self->[IS_TRIDENT] ) # older versions don't have junk outside, while newer might have
        && ! $self->[IS_MAXTHON]           # be sure that this is not the faker
    ) {
        my($n, $v) = split RE_WHITESPACE, $t->[0];
        if ( $n eq 'MSIE' && index($m, q{ }) == NO_IMATCH ) {
            return $self->_parse_msie($m, $t, $e, $n, $v);
        }
    }

    if ( $self->[IS_TRIDENT] ) {
        # http://blogs.msdn.com/b/ieinternals/archive/2013/09/21/internet-explorer-11-user-agent-string-ua-string-sniffing-compatibility-with-gecko-webkit.aspx
        my %msie11 = map {
              index( $_, 'Windows')  != NO_IMATCH ? ( windows => 1 )
            : index( $_, 'Trident/') != NO_IMATCH ? ( trident => 1 )
            : index( $_, 'rv:')      != NO_IMATCH ? ( version => 1 )
            : ()
        } @{ $t };
        my $msie_matched = keys %msie11;

        if ( $msie_matched == 3 ){
            return $self->_parse_msie_11($m, $t, $e);
        }
        elsif ( ! $self->[IS_MAXTHON] && $msie_matched == 2 && ! $msie11{version} ) {
            # another weird case. robot?
            my(@buf, $vstr);
            for my $junk ( @{ $t } ) {
                if ( index( $junk, 'MSIE') != NO_IMATCH ) {
                    $vstr = $junk;
                    next;
                }
                push @buf, $junk;
            }

            my $rv = $self->_parse_msie($m, \@buf, $e, split( RE_WHITESPACE, $vstr ) );
            return $rv;
        }
        # fall back to the dispatch table below
    }

    my $rv =  $self->[IS_MAXTHON]          ? [ maxthon    => $m, $t, $e, @o        ]
            : $self->_is_opera_pre($m)     ? [ opera_pre  => $m, $t, $e            ]
            : $self->_is_opera_post($e)    ? [ opera_post => $m, $t, $e, $c        ]
            : $self->_is_opera_ff($e)      ? [ opera_pre  => "$e->[2]/$e->[3]", $t ]
            : $self->_is_ff($e)            ? [ firefox    => $m, $t, $e, @o        ]
            : $self->_is_safari($e, \@o)   ? [ safari     => $m, $t, $e, @o        ]
            : $self->_is_chrome($e, \@o)   ? [ chrome     => $m, $t, $e, @o        ]
            : $self->_is_android($t,\@o)   ? [ android    => $m, $t, $e, @o        ]
            : $self->_is_suspicious_ff($e) ? [ ff_suspect => $m, $t, $e, @o        ]
            : undef;

    if ( $rv ) {
        my $pname  = shift @{ $rv };
        my $method = '_parse_' . $pname;
        my $rvx    = $self->$method( @{ $rv } );
        if ( $rvx ) {
            $self->[UA_PARSER] ||= $pname;
            return $rvx;
        }
    }

    return $self->_extended_probe($m, $t, $e, $c, @o) if $self->[IS_EXTENDED];

    $self->[UA_UNKNOWN] = 1; # give up
    return;
}

sub _post_parse {
    my $self = shift;
    $self->[UA_VERSION] = $self->_numify( $self->[UA_VERSION_RAW] )
        if $self->[UA_VERSION_RAW];

    my @buf;
    foreach my $e ( @{ $self->[UA_EXTRAS] } ) {
        if ( $self->_is_strength( $e ) ) {
            $self->[UA_STRENGTH] = $e ;
            next;
        }
        push @buf, $e;
    }

    $self->[UA_EXTRAS] = @buf ? [ @buf ] : undef;

    if ( $self->[UA_TOOLKIT] ) {
        my $v = $self->[UA_TOOLKIT][TK_ORIGINAL_VERSION];
        push @{ $self->[UA_TOOLKIT] }, defined $v ? $self->_numify( $v ) : 0;
    }

    if( $self->[UA_MOZILLA] ) {
        $self->[UA_MOZILLA] =~ tr/a-z://d;
        $self->[UA_MOZILLA] = [ $self->[UA_MOZILLA],
                                $self->_numify( $self->[UA_MOZILLA] ) ];
    }

    if ( $self->[UA_OS] ) {
        $self->[UA_OS] = $OSFIX{ $self->[UA_OS] } || $self->[UA_OS];
    }

    foreach my $robo ( LIST_ROBOTS ) { # regex???
        next if lc $robo ne lc $self->[UA_NAME];
        $self->[UA_ROBOT] = 1;
        last;
    }
    return;
}

sub _extended_probe {
    my($self, @args) = @_;

    return if $self->_is_gecko             && $self->_parse_gecko(    @args );
    return if $self->_is_netscape( @args ) && $self->_parse_netscape( @args );
    return if $self->_is_docomo(   @args ) && $self->_parse_docomo(   @args );
    return if $self->_is_generic(  @args );
    return if $self->_is_emacs(    @args ) && $self->_parse_emacs(    @args );
    return if $self->_is_moz_only( @args ) && $self->_parse_moz_only( @args );
    return if $self->_is_hotjava(  @args ) && $self->_parse_hotjava(  @args );

    $self->[UA_UNKNOWN] = 1;
    return;
}

sub _object_ids {
    return grep { $_ =~ RE_OBJECT_ID } keys %Parse::HTTP::UserAgent::;
}

sub _numify {
    my $self = shift;
    my $v    = shift || return 0;
    my @removed;

    if (
        $v =~ s{(
                pre      |
                rel      |
                alpha    |
                beta     |
                \-stable |
                gold     |
                [ab]\d+  |
                a\-XXXX  |
                dev      |
                [+]
               )}{}xmsig
    ){
        push @removed, $1 if INSIDE_VERBOSE_TEST;
    }

    if (
        $v =~ s{(
                (?:[^0-9]+)? # usually dash
                rc           # nonsense
                [\-_.]?      # usually dash
                ([0-9])      # teh candidate revision
            )}{.0.$2}xmsi    # yeah, hacky
    ) {
        push @removed, $1 if INSIDE_VERBOSE_TEST;
    }

    # workaround another stupidity (1.2.3-4)
    if ( my $rc = $v =~ tr/-/./ ) {
        push @removed, '-' x $rc if INSIDE_VERBOSE_TEST;
    }

    # convert _ to .
    # version.pm has changed its interpretation of versions with underlines
    # cf. https://bugs.debian.org/825611
    if ( my $rc = $v =~ tr/_/./ ) {
        push @removed, '-' x $rc if INSIDE_VERBOSE_TEST;
    }

    # Finally, be aggressive to prevent dying on bogus stuff.
    # It's interesting how people provide highly stupid version "numbers".
    # Version parameters are probably more stupid than the UA string itself.
    if ( $v =~ s<([^0-9._v])><.>xmsg ) {
        push @removed, $1 if INSIDE_VERBOSE_TEST;
    }

    if ( $v =~ s<([.]{2,})><.>xmsg ) {
        push @removed, $1 if INSIDE_VERBOSE_TEST;
    }

    if ( INSIDE_VERBOSE_TEST ) {
        if ( @removed ) {
            my $r = join q{','}, @removed;
            require Test::More;
            Test::More::diag("[DEBUG] _numify: removed '$r' from version string");
        }
    }

    # Gecko revisions like: "20080915000512" will cause an
    #   integer overflow warning. use bigint?
    local $SIG{__WARN__} = sub {
        my $msg = shift;
        warn "$msg\n" if $msg !~ RE_WARN_OVERFLOW && $msg !~ RE_WARN_INVALID;
    };
    # if version::vpp is used it'll identify 420 as a v-string
    # add a floating point to fool it
    $v .= q{.0} if index($v, q{.}) == NO_IMATCH;
    (my $check = $v) =~ tr/0-9//cd;
    return 0 if ! $check; # A string parsed as version (i.e.: AppleWebKit/en_SG)
    my $rv;
    eval {
        $rv = version->new("$v")->numify;
        1;
    } or do {
        my $error = $@ || '[unknown error while parsing version]';
        if ( INSIDE_UNIT_TEST ) {
            chomp $error;
            if ( INSIDE_VERBOSE_TEST ) {
                Test::More::diag( "[FATAL] _numify: version said: $error for '$v'" );
                Test::More::diag(
                    sprintf '[FATAL] _numify: UA with bogus version (%s) is: %s',
                                $v, $self->[UA_STRING]
                );
                Test::More::diag( '[FATAL] _numify: ' . $self->dumper );
            }
            croak $error;
        }
        else {
            croak $error;
        }
    };
    return $rv;
}

sub _debug_pre_parse {
    my($self, $moz, $thing, $extra, @others) = @_;

    my $raw = [
                { qw/ name moz    value / => $moz     },
                { qw/ name thing  value / => $thing   },
                { qw/ name extra  value / => $extra   },
                { qw/ name others value / => \@others },
            ];
    my $pok = print "-------------- PRE PARSE DUMP --------------\n"
                  . $self->dumper(args => $raw)
                  . "--------------------------------------------\n";
    return;
}

1;

__END__