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 23     23   340326 use strict;
  23         101  
  23         660  
4 23     23   116 use warnings;
  23         44  
  23         549  
5 23     23   118 use Carp;
  23         41  
  23         1488  
6              
7             package Data::iRealPro::URI;
8              
9 23     23   5637 use Data::iRealPro;
  23         51  
  23         603  
10 23     23   8521 use Data::iRealPro::Playlist;
  23         67  
  23         891  
11 23     23   341 use Encode qw(decode_utf8 encode_utf8);
  23         54  
  23         1191  
12 23     23   11559 use HTML::Entities;
  23         133650  
  23         21960  
13              
14             sub new {
15 24     24 0 1089 my ( $pkg, %args ) = @_;
16 24         111 my $self = bless { %args }, $pkg;
17 24   100     253 $self->{transpose} //= 0;
18 24 100       115 $self->parse( $args{data} ) if $args{data};
19 24 100       114 $self->{playlist} = $args{playlist} if $args{playlist};
20 24         87 return $self;
21             }
22              
23             sub parse {
24 13     13 0 4328 my ( $self, $data ) = @_;
25              
26             # Un-URI-escape and decode.
27 13         1977 $data =~ s/[\r\n]*//g;
28 13         462 $data =~ s;^.+(irealb(?:ook)?://.*?)(?:$|\").*;$1;s;
29 13         104 $data =~ s/%([0-9a-f]{2})/sprintf("%c",hex($1))/gie;
  679         2177  
30 13         86 $data = decode_utf8($data);
31              
32 13 50       851 $self->{data} = $data if $self->{debug};
33              
34 13 50       130 if ( $data =~ m;^irealb(ook)?://; ) {
35 13 50       66 $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 13         130 );
47              
48 13         47 return $self;
49             }
50              
51             sub as_string {
52 7     7 0 3054 my ( $self, $uriesc ) = @_;
53              
54 7         31 my $s = $self->{playlist}->as_string;
55 7 100       26 if ( $uriesc ) {
56 6         37 $s = esc($s);
57             }
58             # warn("irealb://" . $s);
59 7         58 "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 51 my $t = encode_utf8($_[0]);
    139 11         171 $t =~ s/([^-_.A-Z0-9a-z*\/\'])/sprintf("%%%02X", ord($1))/ge;
      572         1652  
    140 11         64 return $t;
    141             }
    142              
    143             1;