File Coverage

blib/lib/Video/Subtitle/SRT.pm
Criterion Covered Total %
statement 56 93 60.2
branch 12 30 40.0
condition 2 9 22.2
subroutine 10 16 62.5
pod 7 11 63.6
total 87 159 54.7


line stmt bran cond sub pod time code
1             package Video::Subtitle::SRT;
2             require Exporter;
3             @ISA = qw(Exporter);
4             @EXPORT_OK = qw/srt_time_to_milliseconds milliseconds_to_srt_time
5             make_subtitle/;
6             %EXPORT_TAGS = (
7             all => \@EXPORT_OK,
8             );
9 2     2   96309 use strict;
  2         6  
  2         468  
10 2     2   161 use warnings;
  2         4  
  2         122  
11             our $VERSION = '0.05';
12              
13 2     2   12 use Carp;
  2         9  
  2         278  
14 2     2   4292 use POSIX 'floor';
  2         39545  
  2         18  
15 2     2   3649 use Carp;
  2         4  
  2         4422  
16              
17             sub new {
18 2     2 1 51 my ($class, $callback) = @_;
19 2         11 bless { callback => $callback }, $class;
20             }
21              
22             # Turn on/off debugging; return value is current debugging value.
23              
24             sub debug
25             {
26 0     0 0 0 my $self = shift;
27 0 0       0 $self->{debug} = shift if @_;
28 0         0 $self->{debug};
29             }
30              
31             sub parse
32             {
33 2     2 1 11 my ($self, $stuff) = @_;
34              
35 2 50 0     13 if (ref($stuff) && (UNIVERSAL::isa($stuff, 'IO::Handle') || ref($stuff) eq 'GLOB')) {
      33        
36 0         0 $self->parse_fh($stuff);
37             }
38             else {
39 2 50       216 open my $fh, "<", $stuff or croak "$stuff: $!";
40 2         13 $self->parse_fh($fh);
41 2 50       71 close $fh or die $!;
42             }
43             }
44              
45             # Read the SRT from file handle $fh.
46              
47             sub parse_fh
48             {
49 2     2 0 8 my ($self, $fh) = @_;
50              
51 2         22 binmode $fh, ":raw:crlf";
52 2         13 local $/ = "\n\n";
53 2         93 while (my $chunk = <$fh>) {
54 2         34 my @chunk = split /\r?\n/, $chunk;
55 2 50       10 if ($chunk[-1] eq "") {
56 0         0 pop @chunk;
57             }
58              
59 2         8 my $data = $self->parse_chunk(\@chunk, $chunk);
60 2 50       15 if ($self->{callback}) {
61 2         5 eval {
62 2         8 $self->{callback}->($data)
63             };
64 2 50 33     2339 warn $@ if $@ && $self->{debug};
65 2 50       17 return if $@;
66             }
67             }
68             }
69              
70             sub parse_chunk
71             {
72 2     2 0 4 my ($self, $chunk_ref, $chunk) = @_;
73              
74 2 50       8 if (@$chunk_ref < 3) {
75 0         0 croak "Odd number of lines: \n$chunk";
76             }
77              
78 2         3 my $data;
79 2 50       17 if ($chunk_ref->[0] !~ /^\d+$/) {
80 0         0 croak "Number must be digits: '$chunk_ref->[0]'";
81             }
82 2         7 $data->{number} = $chunk_ref->[0];
83              
84 2         3 my $time_re = '(\d{2}:\d{2}:\d{2}(?:,\d*)?)';
85 2 50       86 unless ($chunk_ref->[1] =~ /^$time_re --> $time_re$/) {
86 0         0 croak "Invalid time range: $chunk_ref->[1]";
87             }
88 2         11 $data->{start_time} = $1;
89 2         6 $data->{end_time} = $2;
90              
91 2         7 $data->{text} = join "\n", @{$chunk_ref}[2..$#$chunk_ref];
  2         9  
92              
93 2         7 return $data;
94             }
95              
96             sub srt_time_to_milliseconds
97             {
98 0     0 1 0 my ($time) = @_;
99 0 0       0 if ($time !~ /^(\d\d):(\d\d):(\d\d)(?:,(\d*))?$/) {
100 0         0 croak "Time '$time' does not match SRT format";
101             }
102 0         0 my $milliseconds = int ($4);
103 0         0 $milliseconds += ($1 * 60 * 60 + $2 * 60 + $3) * 1000;
104 0         0 return $milliseconds;
105             }
106              
107             sub milliseconds_to_srt_time
108             {
109 0     0 1 0 my ($milliseconds) = @_;
110              
111 0         0 my $seconds = floor ($milliseconds / 1000);
112 0         0 my $minutes = floor ($seconds / 60);
113 0         0 my $hours = floor ($minutes / 60);
114 0         0 $milliseconds %= 1000;
115 0         0 $seconds %= 60;
116 0         0 $minutes %= 60;
117 0         0 return sprintf "%02d:%02d:%02d,%03d",
118             $hours, $minutes, $seconds, $milliseconds;
119             }
120              
121             sub make_subtitle
122             {
123 2     2 1 2168 my ($data) = @_;
124 2         5 my $output = "";
125 2         168 for my $field (qw/number start_time end_time text/) {
126 5 100       19 if (! $data->{$field}) {
127 1         240 croak "Missing $field";
128             }
129             }
130             # Bug: should check that the output has all the fields here.
131 1         5 $output .= $data->{number} . "\n";
132 1         7 $output .= $data->{start_time} . " --> " . $data->{end_time} . "\n";
133 1         25 $output .= $data->{text} . "\n";
134 1         3 $output .= "\n";
135 1         4 return $output;
136             }
137              
138             sub add
139             {
140 0     0 1   my ($object, $data) = @_;
141 0 0         if (! defined $object->{number}) {
142 0           $object->{number} = 0;
143             }
144 0           $object->{number}++;
145 0           $data->{number} = $object->{number};
146 0           $object->{subtitles} .= make_subtitle ($data);
147             }
148              
149             sub write_file
150             {
151 0     0 1   my ($object, $file_name) = @_;
152 0           my $file;
153 0 0         if ($file_name) {
154             # Not finished.
155 0           die;
156             }
157             else {
158 0           $file = *STDOUT;
159             }
160 0           $object->{subtitles} =~ s/\n/\r\n/g;
161 0           print $file $object->{subtitles};
162             }
163            
164             # Set the verbosity of the output.
165              
166             sub set_verbosity
167             {
168 0     0 0   my ($object) = @_;
169 0           $object->{verbosity} = 1;
170             }
171              
172             1;
173              
174             __END__