File Coverage

blib/lib/HTML/SocialMedia/Hashtag.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package HTML::SocialMedia::Hashtag;
2              
3 1     1   30734 use strict;
  1         2  
  1         24  
4 1     1   3 use warnings;
  1         1  
  1         35  
5              
6             =head1 NAME
7              
8             HTML::SocialMedia::Hashtag
9              
10             =head1 DESCRIPTION
11              
12             Get #hashtags and @usernames from html
13              
14             =head1 SYNOPSIS
15              
16             use HTML::SocialMedia::Hashtag;
17             my $scanner = HTML::SocialMedia::Hashtag -> new( text => 'text with #hashtag and @username' );
18             my @hashtags = $scanner -> hashtags();
19             my @usernames = $scanner -> usernames();
20              
21             =cut
22              
23             our $VERSION = '0.3';
24              
25 1     1   523 use Encode qw(decode encode is_utf8);
  1         7545  
  1         55  
26 1     1   456 use HTML::Strip;
  1         4952  
  1         84  
27              
28 1     1   514 use Moose;
  1         289494  
  1         4  
29 1     1   4826 use namespace::autoclean;
  0            
  0            
30              
31             has 'text' => ( is => 'rw', isa => 'Str', required => 1 );
32              
33             =head1 METHODS
34              
35             =head2 hashtags()
36              
37             Get lowercased and unique hashtags from html
38              
39             =cut
40              
41             sub hashtags {
42             my ( $self ) = @_;
43              
44             my @hashtags = map { _encode_utf( lc( _decode_utf( $_ ) ) ) } $self -> all_hashtags();
45              
46             return _uniq_array( @hashtags );
47             }
48              
49             =head2 all_hashtags()
50              
51             Get all hashtags
52              
53             =cut
54              
55             sub all_hashtags {
56             my ( $self ) = @_;
57              
58             my $strip = HTML::Strip -> new();
59             $strip -> set_decode_entities( 0 );
60              
61             my $parsed_text = $strip -> parse( $self -> text() );
62              
63             my @all_hashtags;
64              
65             while ( $parsed_text =~ /(^|\s|>)\#(\S+)/gxo ) {
66             my $hashtag = $2;
67              
68             $hashtag =~ s/(,)*$//g;
69             $hashtag =~ s/(!)*!$//g;
70             $hashtag =~ s/(\.)*$//g;
71             $hashtag =~ s/(\?)*$//g;
72             $hashtag =~ s/(<).*$//g;
73              
74             push @all_hashtags, $hashtag;
75             }
76              
77             return @all_hashtags;
78             }
79              
80             =head2 nicknames()
81              
82             Get unique nicknames from html
83              
84             =cut
85              
86             sub nicknames {
87             my ( $self ) = @_;
88              
89             return _uniq_array( $self -> all_nicknames() );
90             }
91              
92             =head2 all_nicknames()
93              
94             Get all nicknames
95              
96             =cut
97              
98             sub all_nicknames {
99             my ( $self ) = @_;
100              
101             my @nicknames;
102              
103             my $text = $self -> text();
104              
105             while ( $text =~ /\@(\S+)/gxo ) {
106             my $nickname = $1;
107              
108             $nickname =~ s/(,)*$//g;
109             $nickname =~ s/(!)*!$//g;
110             $nickname =~ s/(\.)*$//g;
111             $nickname =~ s/(\?)*$//g;
112              
113             push @nicknames, $nickname;
114             }
115              
116             return @nicknames;
117             }
118              
119             sub _uniq_array {
120             my ( @array ) = @_;
121              
122             my %seen = ();
123              
124             return grep { ! $seen{ $_ } ++ } @array;
125             }
126              
127             sub _encode_utf {
128             my ( $string ) = @_;
129              
130             my $result = is_utf8( $string )
131             ? encode( 'UTF-8', $string )
132             : $string;
133              
134             if( is_utf8( $result ) ) {
135             utf8::downgrade( $result );
136             }
137              
138             return $result;
139             }
140              
141             sub _decode_utf {
142             my ( $string ) = @_;
143              
144             return is_utf8( $string )
145             ? $string
146             : decode( 'UTF-8', $string );
147             }
148              
149             __PACKAGE__ -> meta() -> make_immutable();
150              
151             1;
152              
153             __END__
154              
155             =head1 AUTHOR
156              
157             German Semenkov
158             german.semenkov@gmail.com
159              
160             =cut