File Coverage

blib/lib/Data/iRealPro/URI.pm
Criterion Covered Total %
statement 47 71 66.2
branch 9 22 40.9
condition 2 7 28.5
subroutine 11 12 91.6
pod 0 5 0.0
total 69 117 58.9


line stmt bran cond sub pod time code
1             #! perl
2              
3 21     21   327543 use strict;
  21         95  
  21         596  
4 21     21   119 use warnings;
  21         39  
  21         498  
5 21     21   102 use Carp;
  21         42  
  21         1583  
6              
7             package Data::iRealPro::URI;
8              
9 21     21   5389 use Data::iRealPro;
  21         50  
  21         539  
10 21     21   7411 use Data::iRealPro::Playlist;
  21         54  
  21         796  
11 21     21   283 use Encode qw(decode_utf8 encode_utf8);
  21         45  
  21         1109  
12 21     21   10563 use HTML::Entities;
  21         120362  
  21         19922  
13              
14             sub new {
15 22     22 0 978 my ( $pkg, %args ) = @_;
16 22         101 my $self = bless { %args }, $pkg;
17 22   100     250 $self->{transpose} //= 0;
18 22 100       89 $self->parse( $args{data} ) if $args{data};
19 22 100       87 $self->{playlist} = $args{playlist} if $args{playlist};
20 22         76 return $self;
21             }
22              
23             sub parse {
24 12     12 0 4157 my ( $self, $data ) = @_;
25              
26             # Un-URI-escape and decode.
27 12         1902 $data =~ s/[\r\n]*//g;
28 12         414 $data =~ s;^.+(irealb(?:ook)?://.*?)(?:$|\").*;$1;s;
29 12         83 $data =~ s/%([0-9a-f]{2})/sprintf("%c",hex($1))/gie;
  634         2027  
30 12         72 $data = decode_utf8($data);
31              
32 12 50       858 $self->{data} = $data if $self->{debug};
33              
34 12 50       127 if ( $data =~ m;^irealb(ook)?://; ) {
35 12 50       64 $self->{variant} = $1 ? "irealbook" : "irealpro";
36             }
37             else {
38 0         0 Carp::croak("Invalid input: ", substr($data, 0, 40) );
39             }
40              
41             $self->{playlist} =
42             Data::iRealPro::Playlist->new( variant => $self->{variant},
43             data => $data,
44             debug => $self->{debug},
45             transpose => $self->{transpose},
46 12         123 );
47              
48 12         43 return $self;
49             }
50              
51             sub as_string {
52 7     7 0 2658 my ( $self, $uriesc ) = @_;
53              
54 7         32 my $s = $self->{playlist}->as_string;
55 7 100       22 if ( $uriesc ) {
56 6         45 $s = esc($s);
57             }
58             # warn("irealb://" . $s);
59 7         55 "irealb://" . $s;
60             }
61              
62             sub export {
63 0     0 0 0 my ( $self, %args ) = @_;
64 0         0 carp(__PACKAGE__."::export is deprecated, please use 'as_string' instead");
65 0   0     0 my $v = $args{variant} || $self->{variant} || "irealpro";
66 0   0     0 $args{uriencode} //= !$args{plain};
67              
68 0         0 my $uri = $self->as_string(%args);
69 0 0       0 return $uri unless $args{html};
70              
71 0         0 my $title;
72             my $pl;
73              
74 0 0       0 if ( $args{playlist}) {
75 0         0 $pl = $self->{playlist};
76 0         0 $title = encode_entities($pl->{name});
77             }
78             else {
79 0         0 $title = encode_entities($self->{playlist}->{songs}->[0]->{title});
80             }
81              
82 0         0 my $html = <
83            
84            
85            
86            
87             $title
88            
103            
104            
105            

$title
106             EOD
107              
108 0 0       0 if ( $args{playlist}) {
109 0         0 $html .= "

(All songs)

\n
    \n";
110 0         0 foreach my $s ( @{ $pl->{songs} } ) {
  0         0  
111 0         0 my @c = split(' ', $s->{composer});
112 0 0       0 my $c = @c == 2 ? "$c[1] $c[0]" : $s->{composer};
113             $html .= "
    • 114             $s->export( variant => "irealpro", uriencode => 1 ) .
    115             "\">" .
    116             encode_entities($s->{title}) .
    117             " - " .
    118             encode_entities($c) .
    119 0 0       0 ( $s->{ts} ? " (@{[$s->{ts}]})" : "" ) .
      0         0  
    120             "\n";
    121             }
    122              
    123 0         0 $html .= " \n";
    124             }
    125             else {
    126 0         0 $html .= qq{

    $title

    \n};
    127             }
    128              
    129 0         0 $html .= <
    130            

    Generated by Data::iRealPro version $Data::iRealPro::VERSION.
    131            
    132            
    133             EOD
    134             }
    135              
    136             sub esc {
    137             # We must encode first before the uri-escape.
    138 11     11 0 50 my $t = encode_utf8($_[0]);
    139 11         164 $t =~ s/([^-_.A-Z0-9a-z*\/\'])/sprintf("%%%02X", ord($1))/ge;
      572         1621  
    140 11         59 return $t;
    141             }
    142              
    143             1;