File Coverage

blib/lib/WWW/Yandex/Catalog/LookupSite.pm

Criterion	Covered	Total	%
statement	14	78	17.9
branch	0	20	0.0
condition	0	2	0.0
subroutine	6	17	35.2
pod	10	10	100.0
total	30	127	23.6

package WWW::Yandex::Catalog::LookupSite;

# Last updated July 27, 2014
#
# Author:       Irakliy Sunguryan ( www.sochi-travel.info )
# Date Created: January 30, 2010

use strict;
use warnings;

use vars qw($VERSION);
$VERSION    = '0.11';

use LWP::UserAgent;

my $HAS_PUNYMOD;
BEGIN { $HAS_PUNYMOD = eval 'use URI::UTF8::Punycode; 1;'; }


sub new {
    my $class = shift;
    my %options = @_;

    my $self = {
        _tic        => undef,
            # undef - if there was an error getting or parsing data
            # 0     - (a) when site is not present in catalog and tIC is < 10
            #       - (b) when site is present in catalog, but the catalog
            #             reports it as zero (payed submission)
        _shortDescr => undef,
            # defined only when site is present in catalog; undef otherwise
        _longDescr  => undef,
            # can be undef when site is present in catalog!
            # not all sites in the catalog have long description
        _categories => [],
            # empty when site is not present in catalog
            # at least one entry when present in catalog
        _orderNum   => undef,
            # order number in the sub-category of catalog; "main" subcategory,
            # when there are more than one.
            # defined only when site is present in the catalog; undef otherwise
        _uri        => undef,
            # URI as it is recorded in catalog. for example with/without 'www' prefix
            # or it can be recorded with totally different address (narod.ru -> narod.yandex.ru)
            # defined only when site is present in catalog; undef otherwise
    };

    $self->{ua} = LWP::UserAgent->new( agent => __PACKAGE__ . "/" . $VERSION );

    # Pass options on to LWP::UserAgent
    foreach my $option ( keys %options ) {
        $self->{ua}->$option( $options{$option} );
    }

    bless $self, $class;
    return $self;
}


# Returns [ tIC, short description, long description, [list of catalogs], URI as returned by Yaca, order number in the main category ]
# "yaca" - Yandex Catalog
sub yaca_lookup {
    my $self = shift;

    my $address = shift || return;

    # an $address is nomally a domain name (whatever level), but can include path too.
    # scheme, authentication, port, and query strings are stripped --
    #   assuming Yandex won't accept URIs that contain all this

    $self->{_tic} = $self->{_shortDescr} = $self->{_longDescr} = $self->{_orderNum} = $self->{_uri} = undef;
    $self->{_categories} = [];

    $address =~ s|.*?://||;       # loose scheme
    $address =~ s|.*?(:.*?)?@||;  # loose authentication
    $address =~ s|(\w):\d+|$1|;   # loose port
    $address =~ s|\?.*||;         # loose query
    $address =~ s|/$||;           # loose trailing slash

    my $resp = $self->{ua}->get( 'http://yaca.yandex.ru/yca/cy/ch/' . $address . '/' );
    return unless $resp->is_success;

    my $contents = $resp->decoded_content;

    if( $contents =~ // ) {
        # "ресурс не описан в Яндекс.Каталоге"
        # It's not in the catalog, but tIC is always displayed.
        # Ex.: Индекс цитирования (тИЦ) ресурса — 10
        ( $self->{_tic} ) = $contents =~ /.*?\s(\d+)/s;
        $self->{_tic} = 0 unless defined $self->{_tic};
        }
    else {
        my( $entry ) = $contents =~ qr{(

        ( $self->{_orderNum}, $self->{_uri}, $self->{_shortDescr}, undef, $self->{_longDescr}, $self->{_tic} ) =
            #                  $1                       $2        $3            $4             $5
            $entry =~ qr{

        # main catalog
        my( $path, $rubric ) = $contents =~ qr{(.*?)\s*(.*?)}s;
        if( $path ) {
            $path =~ s{||\n}{}gs; # remove A, H1 tags and newline
            $path =~ s|\x{0420}\x{0443}\x{0431}\x{0440}\x{0438}\x{043A}\x{0438} / ||;
                # removed "Рубрики" - it always starts with this root word
                # http://www.rishida.net/tools/conversion/
            push( @{$self->{_categories}}, $path.' / '.$rubric ) if $entry;
        }

        # additional catalogs
        ( $entry ) = $contents =~ qr{(.*?)}s;
        if( $entry ) {
            while( $entry =~ s{(.*?).*?(
                my $catPath = $1;
                $catPath =~ s|\x{041A}\x{0430}\x{0442}\x{0430}\x{043B}\x{043E}\x{0433} / ||;
                    # removed "Каталог" - we know it's in the catalog
                push( @{$self->{_categories}}, $catPath ) if $catPath;
            }
        }
    }

    return [ $self->{_tic}, $self->{_shortDescr}, $self->{_longDescr}, $self->{_categories}, $self->{_uri}, $self->{_orderNum} ];
}

# Converts punycode in a IDN URL to utf8.
# Returns converted URL.
sub _punycode_utf8 {
    my $uri = shift;

    s/^\s+//, s/\s+$// for $uri; # trim $uri just in case
    my( $schema, $domain, $path ) = $uri =~ m{(http.*?//)(.*?)(($|/|:).*)};
        # Ex.: http://www.domain.com:80/path?query#anchor -> 'http://' , 'www.domain.com' , ':80/path?query#anchor'
        # I hope there are no urls with username/password links in YaCa
        # I hope there are no non-http(s) links in YaCa
        # I hope all links include schema part
        # Anyway, from what I've seen in YaCa so far we should be Ok

    $domain = join( '.', map { /^xn--/ ? puny_dec($_) : $_ } split(/\./, $domain) );
        # split by dot -> convert only punycode parts -> glue 'em back together

    return $schema.$domain.$path;
}

# == Convenience functions =================================

sub is_in_catalog {
    my $self = shift;
    return scalar @{$self->{_categories}} > 0 ? 1 : 0;
}

sub tic {
    my $self = shift;
    return $self->{_tic};
}

sub short_description {
    my $self = shift;
    return $self->{_shortDescr};
}

sub long_description {
    my $self = shift;
    return $self->{_longDescr};
}

sub categories {
    my $self = shift;
    return $self->{_categories};
}

sub order_number {
    my $self = shift;
    return $self->{_orderNum};
}

sub uri {
    my $self = shift;
    return $self->{_uri};
}

sub uri_utf8 {
    my $self = shift;
    return $HAS_PUNYMOD ? _punycode_utf8( $self->{_uri} ) : $self->{_uri};
}

1;

__END__