File Coverage

blib/lib/HTTP/UA/Parser.pm

Criterion	Covered	Total	%
statement	147	203	72.4
branch	48	66	72.7
condition	6	32	18.7
subroutine	32	42	76.1
pod	5	5	100.0
total	238	348	68.3

package HTTP::UA::Parser;
use strict;
use warnings;
use YAML::Tiny 'LoadFile';
our $VERSION = '0.006';
my ($REGEX, $PATH, $PARSER);
my $PACKAGE = __PACKAGE__;

sub new {
    my ($class, $op) = @_;
    my ($ua, $path);
    if (ref $op eq 'HASH'){
        $path = $op->{regex};
        $ua = $op->{ua};
    } else { $ua = $op; }

    if (!$REGEX){
        if ($path){
            $REGEX ||= LoadFile( $path );
        } else {
            $PATH = HTTP::UA::Parser::Utils::getPath();
            my $regFile;
            unless (-e ($regFile = $PATH.'/regexes.yaml')){
                die
                "Can't find regexes.yaml file\n".
                "you can download/update it using command line by typing\n".
                "    % ua_parser -u\n".
                "or simply download it from\n".
                "https://raw.githubusercontent.com/ua-parser/uap-core/master/regexes.yaml".
                "and include it as an option when construct new HTTP::UA::Parser class\n".
                "ex ->new({regex => '/full/path/to/regexes.yaml'})";
            }
            $REGEX = LoadFile( $regFile );
        }
    }

    my $self = {
        user_agent => $ua || $ENV{HTTP_USER_AGENT},
        path => $PATH
    };

    return bless($self,$class);
}

sub parse {
    my $self = shift;
    $self->{user_agent} = $_[0];
    $self->{os} = undef;
    $self->{ua} = undef;
    $self->{device} = undef;
    return $self;
}

sub os {
    my ($self) = @_;
    $self->{os} ||= HTTP::UA::Parser::OS->parse($self->{user_agent});
    return $self->{os};
}

sub ua {
    my ($self) = @_;
    $self->{ua} ||= HTTP::UA::Parser::UA->parse($self->{user_agent});
    return $self->{ua};
}

sub device {
    my ($self) = @_;
    $self->{device} ||= HTTP::UA::Parser::Device->parse($self->{user_agent});
    return $self->{device};
}

##=============================================================================
## UA Package
##=============================================================================
package HTTP::UA::Parser::UA;

sub new {HTTP::UA::Parser::Base::new(@_)}

sub parse {
    my $self = shift;
    my $ua = shift;
    my $parser = $PARSER->{ua} || ($PARSER->{ua} = $self->makeParser($REGEX->{user_agent_parsers}));
    return $parser->($ua);
}

sub makeParser {
    my $self = shift;
    my $regexes = shift;
    return HTTP::UA::Parser::Utils::makeParser($regexes, \&_makeParsers);
}

sub _makeParsers {

    my ($obj) = shift;
    my $regexp = $obj->{regex};
    my $famRep = $obj->{family_replacement};
    my $majorRep = $obj->{v1_replacement};
    my $minorRep = $obj->{v2_replacement};
    my $patchRep = $obj->{v3_replacement};
    my $qr = HTTP::UA::Parser::Utils::regex($regexp);

    my $parser = sub {
        my $str = shift;
        my @m = $str =~ $qr;
        if (!@m) { return undef; }
        my $family = defined $famRep ? HTTP::UA::Parser::Utils::replace($famRep,qr/\$1/,$m[0]) : $m[0];
        my $major = defined $majorRep ?  $majorRep : $m[1];
        my $minor = defined $minorRep ?  $minorRep : $m[2];
        my $patch = defined $patchRep ?  $patchRep : $m[3];
        return ($family, $major, $minor, $patch);
    };

    return $parser;
}

##=============================================================================
## OS Package
##=============================================================================
package HTTP::UA::Parser::OS;

sub new {HTTP::UA::Parser::Base::new(@_)}

sub parse {
    my $self = shift;
    my $ua = shift;
    my $parser = $PARSER->{os} || ($PARSER->{os} = $self->makeParser($REGEX->{os_parsers}));
    return $parser->($ua);
}

sub makeParser {
    my $self = shift;
    my $regexes = shift;
    return HTTP::UA::Parser::Utils::makeParser($regexes, \&_makeParsers);
}

sub _makeParsers {

    my ($obj) = shift;
    my $regexp = $obj->{regex};
    my $famRep = $obj->{os_replacement};
    my $majorRep = $obj->{os_v1_replacement};
    my $minorRep = $obj->{os_v2_replacement};
    my $patchRep = $obj->{os_v3_replacement};
    my $patchMinorRep = $obj->{os_v4_replacement};
    my $qr = HTTP::UA::Parser::Utils::regex($regexp);

    my $parser = sub {
        my $str = shift;
        my @m = $str =~ $qr;
        if (!@m) { return undef; }
        my $family = $famRep ? HTTP::UA::Parser::Utils::replace($famRep,qr/\$1/,$m[0]) : $m[0];
        my $major = defined $majorRep ? $majorRep : $m[1];
        my $minor = defined $minorRep ? $minorRep : $m[2];
        my $patch = defined $patchRep ? $patchRep : $m[3];
        my $patchMinor = defined $patchMinorRep ? $patchMinorRep : $m[4];
        return ($family, $major, $minor, $patch, $patchMinor);
    };

    return $parser;
}

##=============================================================================
## Device Package
##=============================================================================
package HTTP::UA::Parser::Device;

sub new {
    my $class = shift;
    my $self = {
        family => $_[0] || 'Other',
        brand => $_[1],
        model => $_[2]
    };
    return bless($self, 'HTTP::UA::Parser::Base');
}

sub toString {
    my $self = shift;
    return $self->family;
}

sub parse {
    my $self = shift;
    my $ua = shift;
    my $parser = $PARSER->{device} || ($PARSER->{device} = $self->makeParser($REGEX->{device_parsers}));
    return $parser->($ua);
}

sub makeParser {
    my $self = shift;
    my $regexes = shift;
    my $makeParser = shift || \&_makeParsers;
    my @parsers = map {
        $makeParser->($_);
    } @{$regexes};

    my $parser = sub {
        my $ua = shift;
        my @obj;
        foreach my $parser (@parsers){
            @obj = $parser->($ua);
            return HTTP::UA::Parser::Device->new(@obj) if $obj[0];
        }

        HTTP::UA::Parser::Device->new();
    };

    return $parser;
}

sub _makeParsers {
    my ($obj) = shift;
    my $regexp = $obj->{regex};
    my $regexp_flag = $obj->{regex_flag};
    my $deviceRep = $obj->{device_replacement};
    my $brandRep = $obj->{brand_replacement};
    my $modelRep = $obj->{model_replacement};
    my $qr = HTTP::UA::Parser::Utils::regex($regexp, $regexp_flag);

    my $parser = sub {
        my $str = shift;
        my @m = $str =~ $qr;
        if (!@m) { return undef; }
        my $family = $deviceRep ? HTTP::UA::Parser::Utils::multiReplace($deviceRep, \@m)
                                : ($m[0] eq "1" ? undef : $m[0]);

        my $brand  = $brandRep  ? HTTP::UA::Parser::Utils::multiReplace($brandRep, \@m)
                                : undef;

        my $model  = $modelRep  ? HTTP::UA::Parser::Utils::multiReplace($modelRep, \@m)
                                : ($m[0] eq "1" ? undef : $m[0]);

        return ($family, $brand, $model);
    };
    return $parser;
}

##=============================================================================
## Stringify Package
##=============================================================================
package HTTP::UA::Parser::Base;

sub new {
    my $class = shift;
    my $self = {
        family => $_[0] || 'Other',
        major => $_[1],
        minor => $_[2],
        patch => $_[3],
        patchMinor => $_[4]
    };
    return bless($self, __PACKAGE__ );
}

sub toVersionString {
    my $self  = shift;
    my $output = '';
    if (defined $self->{major}){
        $output .= $self->{major};
        if (defined $self->{minor}){
            $output .= '.' . $self->{minor};
            if (defined $self->{patch}) {
                if (HTTP::UA::Parser::Utils::startsWithDigit($self->{patch})) { $output .= '.'; }
                $output .= $self->{patch};
                if (defined $self->{patchMinor}) {
                    if (HTTP::UA::Parser::Utils::startsWithDigit($self->{patchMinor})) { $output .= '.'; }
                    $output .= $self->{patchMinor};
                }
            }
        }
    }
    return $output;
}

sub toString {
    my $self = shift;
    my $suffix = $self->toVersionString();
    if ($suffix){
        $suffix = ' ' . $suffix;
    }
    return $self->family . $suffix;
}

sub family     {   shift->{family}     }
sub major      {   shift->{major}      }
sub minor      {   shift->{minor}      }
sub patch      {   shift->{patch}      }
sub patchMinor {   shift->{patchMinor} }
sub brand      {   shift->{brand}      }
sub model      {   shift->{model}      }

##=============================================================================
## Utils Package
##=============================================================================
package HTTP::UA::Parser::Utils;

sub makeParser {
    my $regexes = shift;
    my $makeParser = shift;
    my @parsers = map {
        $makeParser->($_);
    } @{$regexes};

    my $parser = sub {
        my $ua = shift;
        my @obj;
        foreach my $parser (@parsers){
            @obj = $parser->($ua);
            return HTTP::UA::Parser::Base->new(@obj) if $obj[0];
        }

        HTTP::UA::Parser::Base->new();
    };

    return $parser;
}

sub replace {
    my ($stringToReplace,$expr,$replaceWith) = @_;
    $stringToReplace =~ s/$expr/$replaceWith/;
    return $stringToReplace;
}

sub multiReplace {
    my ($stringToReplace, $matches) = @_;
    for ($stringToReplace) {
        s{
            \$(\d)
        }{
            defined @{$matches}[$1-1] ? @{$matches}[$1-1] : '';
        }egx;
        s{^\s+|\s+$}{};
    }
    if ($stringToReplace eq '') {
        undef $stringToReplace;
    }
    return $stringToReplace;
}

# precompile regex
sub regex {
    my ($expr, $flag) = @_;
    $flag = $flag || '';
    if ($flag eq "i") {
        return qr{$expr}i;
    }
    return qr{$expr};
}

sub startsWithDigit {
    my $str = shift;
    return $str =~ /^\d/;
}

sub getPath {
    $PATH = $PACKAGE;
    $PATH =~ s/::/\//g;
    $PATH .= '.pm';
    $PATH = $INC{$PATH};
    $PATH =~ s/.pm$//;
    return $PATH;
}

1;

__END__