The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

BAYASHI / Duadua-0.34 / lib / Duadua / Parser.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
—
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

              
package Duadua::Parser;
use strict;
use warnings;
use Duadua::Util;
my $BLANK_UA = {
    name => 'UNKNOWN',
};
sub parse {
    my ($class, $d) = @_;
    my $index_mozilla = index($d->ua, 'Mozilla/');
    if ($index_mozilla == 0) {
        $d->{_contain_mozilla_top} = 1;
        $d->{_contain_mozilla} = 1;
    } elsif ($index_mozilla > 0) {
        $d->{_contain_mozilla} = 1;
    }
    for my $m (@{$d->parsers}) {
        if ( my $res = $m->try($d) ) {
            return $res;
        }
    }
    # Blank or '-'
    if ($d->ua eq '' || $d->ua eq '-') {
        return $BLANK_UA;
    }
    if ( my $browser = $class->_detect_general_browser($d) ) {
        return $browser;
    }
    if ( my $bot = $class->_detect_general_bot($d) ) {
        return $bot;
    }
    return $BLANK_UA;
}
sub _detect_general_browser {
    my ($class, $d) = @_;
    if ( index($d->ua, 'rowser') > 0 && $d->_prefix('Mozilla/') ) {
        if ( $d->ua =~ m![^a-zA-Z]([a-zA-Z]+[bB]rowser)/([\d.]+)! ) {
            my %h = %{$BLANK_UA};
            ($h{name}, $h{version}) = ($1, $2);
            return Duadua::Util->set_os($d, \%h);
        }
    }
}
sub _detect_general_bot {
    my ($class, $d) = @_;
    my %h = %{$BLANK_UA};
    if ( $d->_contain('https://') || $d->_contain('http://') ) {
        $h{is_bot} = 1;
        if ( !$d->_contain('Mozilla/') && $d->ua =~ m!^([^/;]+)/(v?[\d.]+)! ) {
            my ($name, $version) = ($1, $2);
            $h{name}    = $name;
            $h{version} = $version;
        }
        elsif ( $d->ua =~ m![\s\(]([^(/\s:;]+(?:bot|crawl|crawler|spider|fetcher))/(v?[\d.]+)!i ) {
            my ($name, $version) = ($1, $2);
            $h{name}    = $1;
            $h{version} = $version;
        }
        elsif ( $d->ua =~ m!([a-zA-Z0-9\-\_\.\!]+(?:bot|crawler))!i ) {
            $h{name} = $1;
        }
        return \%h;
    }
}
1;
__END__
=encoding UTF-8
=head1 NAME
Duadua::Parser - Parser of Duadua
=head1 METHODS
=head2 parse($d_obj)
Do parse
=head1 AUTHOR
Dai Okabayashi E<lt>bayashi@cpan.orgE<gt>
=head1 LICENSE
C<Duadua> is free software; you can redistribute it and/or modify it under the terms of the Artistic License 2.0. (Note that, unlike the Artistic License 1.0, version 2.0 is GPL compatible by itself, hence there is no benefit to having an Artistic 2.0 / GPL disjunction.) See the file LICENSE for details.
=cut