File Coverage

blib/lib/HTML/SocialMedia/Hashtag.pm
Criterion Covered Total %
statement 62 63 98.4
branch 3 6 50.0
condition n/a
subroutine 14 14 100.0
pod 4 4 100.0
total 83 87 95.4


line stmt bran cond sub pod time code
1             package HTML::SocialMedia::Hashtag;
2              
3 1     1   29376 use strict;
  1         1  
  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.4';
24              
25 1     1   489 use Encode qw(decode encode is_utf8);
  1         7401  
  1         54  
26 1     1   421 use HTML::Strip;
  1         4823  
  1         37  
27              
28 1     1   468 use Moose;
  1         276484  
  1         4  
29 1     1   4749 use namespace::autoclean;
  1         5155  
  1         3  
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 29     29 1 75 my ( $self ) = @_;
43              
44 1     1   1122 my @hashtags = map { _encode_utf( lc( _decode_utf( $_ ) ) ) } $self -> all_hashtags();
  1         8  
  1         11  
  29         36  
  48         173  
45              
46 29         61 return _uniq_array( @hashtags );
47             }
48              
49             =head2 all_hashtags()
50              
51             Get all hashtags
52              
53             =cut
54              
55             sub all_hashtags {
56 29     29 1 22 my ( $self ) = @_;
57              
58 29         75 my $strip = HTML::Strip -> new();
59 29         1001 $strip -> set_decode_entities( 0 );
60              
61 29         821 my $parsed_text = $strip -> parse( $self -> text() );
62              
63 29         385 my @all_hashtags;
64              
65 29         98 while ( $parsed_text =~ /(^|\s|>)\#(\S+)/gxo ) {
66 48         51 my $hashtag = $2;
67              
68 48         156 $hashtag =~ s/(,)*$//g;
69 48         51 $hashtag =~ s/(!)*!$//g;
70 48         105 $hashtag =~ s/(\.)*$//g;
71 48         101 $hashtag =~ s/(\?)*$//g;
72 48         44 $hashtag =~ s/(<).*$//g;
73              
74 48         181 push @all_hashtags, $hashtag;
75             }
76              
77 29         83 return @all_hashtags;
78             }
79              
80             =head2 nicknames()
81              
82             Get unique nicknames from html
83              
84             =cut
85              
86             sub nicknames {
87 26     26 1 65 my ( $self ) = @_;
88              
89 26         31 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 26     26 1 24 my ( $self ) = @_;
100              
101 26         21 my @nicknames;
102              
103 26         633 my $text = $self -> text();
104              
105 26         82 while ( $text =~ /\@(\S+)/gxo ) {
106 39         44 my $nickname = $1;
107              
108 39         126 $nickname =~ s/(,)*$//g;
109 39         52 $nickname =~ s/(!)*!$//g;
110 39         101 $nickname =~ s/(\.)*$//g;
111 39         86 $nickname =~ s/(\?)*$//g;
112              
113 39         85 push @nicknames, $nickname;
114             }
115              
116 26         55 return @nicknames;
117             }
118              
119             sub _uniq_array {
120 55     55   59 my ( @array ) = @_;
121              
122 55         54 my %seen = ();
123              
124 55         109 return grep { ! $seen{ $_ } ++ } @array;
  87         1601  
125             }
126              
127             sub _encode_utf {
128 48     48   16716 my ( $string ) = @_;
129              
130 48 50       122 my $result = is_utf8( $string )
131             ? encode( 'UTF-8', $string )
132             : $string;
133              
134 48 50       881 if( is_utf8( $result ) ) {
135 0         0 utf8::downgrade( $result );
136             }
137              
138 48         98 return $result;
139             }
140              
141             sub _decode_utf {
142 48     48   44 my ( $string ) = @_;
143              
144 48 50       118 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