File Coverage

blib/lib/Time/Timecode.pm
Criterion Covered Total %
statement 148 151 98.0
branch 46 54 85.1
condition 32 52 61.5
subroutine 41 41 100.0
pod 5 5 100.0
total 272 303 89.7


line stmt bran cond sub pod time code
1             package Time::Timecode;
2              
3 5     5   19500 use strict;
  5         29  
  5         117  
4 5     5   21 use warnings;
  5         8  
  5         187  
5             use overload
6 5         24 '+' => '_add',
7             '-' => '_subtract',
8             '*' => '_multiply',
9             '/' => '_divide',
10             'cmp' => '_compare',
11             '<=>' => '_compare',
12 5     5   4583 '""' => 'to_string';
  5         3982  
13              
14 5     5   2552 use POSIX ();
  5         30527  
  5         103  
15 5     5   26 use Carp ();
  5         9  
  5         477  
16              
17             our $VERSION = '0.32';
18              
19             our $DEFAULT_FPS = 29.97;
20             our $DEFAULT_DROPFRAME = 0;
21             our $DEFAULT_DELIMITER = ':';
22             our $DEFAULT_FRAME_DELIMITER = $DEFAULT_DELIMITER;
23             our $DEFAULT_TO_STRING_FORMAT = ''; # If not set $TO_STRING_FORMAT is used
24              
25             my $SECONDS_PER_MINUTE = 60;
26             my $SECONDS_PER_HOUR = $SECONDS_PER_MINUTE * 60;
27             my $TO_STRING_FORMAT = '%02s%s%02s%s%02s%s%02s'; #HH:MM:SS:FF
28              
29             my $TIME_PART = qr|[0-5]\d|;
30             my $DROP_FRAME_DELIMITERS = '.;'; #, too?
31             my $FRAME_PART_DELIMITERS = "${DEFAULT_DELIMITER}${DROP_FRAME_DELIMITERS}";
32              
33             {
34 5     5   24 no strict 'refs';
  5         8  
  5         9587  
35              
36             my @methods = qw|hours minutes seconds frames fps is_dropframe total_frames|;
37             my %method_aliases = (
38             hours => ['hh', 'hrs'],
39             minutes => ['mm', 'mins'],
40             seconds => ['ss', 'secs'],
41             frames => ['ff']
42             );
43              
44             for my $accessor (@methods) {
45 1124     1124   3454 *$accessor = sub { (shift)->{$accessor} };
46             *$_ = \&$accessor for @{$method_aliases{$accessor}};
47             }
48             }
49              
50             sub new
51             {
52 79 50 33 79 1 1199 Carp::croak 'usage: Time::Timecode->new( TIMECODE [, OPTIONS ] )' if @_ < 2 || !defined($_[1]);
53              
54 79         105 my $class = shift;
55 79 100       172 my $options = ref($_[-1]) eq 'HASH' ? pop : {};
56             my $self = bless { is_dropframe => $options->{dropframe},
57             frame_delimiter => $options->{frame_delimiter},
58             delimiter => $options->{delimiter} || $DEFAULT_DELIMITER,
59 79   66     406 fps => $options->{fps} || $DEFAULT_FPS }, $class;
      66        
60              
61 79 100       755 Carp::croak "Invalid fps '$self->{fps}': fps must be >= 0" unless $self->{fps} =~ /\A\d+(?:\.\d+)?\z/;
62              
63 78 100 100     293 if(@_ == 1 && $_[0] !~ /^\d+$/) {
64 12         32 $self->_timecode_from_string( shift );
65             }
66             else {
67             # For string timecodes these can be derrived by their format
68 66 100       135 $self->{is_dropframe} = $DEFAULT_DROPFRAME unless defined $self->{is_dropframe};
69 66   66     176 $self->{frame_delimiter} ||= $DEFAULT_FRAME_DELIMITER;
70              
71 66 100       100 if(@_ == 1) {
72 52         86 $self->_timecode_from_total_frames( shift );
73             }
74             else {
75             # Add frames if necessary
76 14 100       29 push @_, 0 unless @_ == 4;
77 14         28 $self->_set_and_validate_time(@_);
78             }
79             }
80              
81 75 50       116 if ($self->_is_deprecated_dropframe_rate) {
82 0         0 warn<
83             Time::Timecode warning: versions > 0.3X will not treat drop frame 30 and 60 like 29.97 and 59.94. Use an fps of 29.97 or 59.94 instead.
84             DEPRECATION
85             }
86              
87 75         277 $self;
88             }
89              
90             sub to_string
91             {
92 26     26 1 59 my $self = shift;
93 26   100     75 my $format = shift || $DEFAULT_TO_STRING_FORMAT;
94             my $tc = sprintf $TO_STRING_FORMAT, $self->hours,
95             $self->{delimiter},
96             $self->minutes,
97             $self->{delimiter},
98             $self->seconds,
99             $self->{frame_delimiter},
100 26         55 $self->frames;
101              
102 26 100       58 if($format) {
103 15         17 my @args;
104             # TODO: Add %X too?
105 15         23 my %formats = (H => $self->hours,
106             M => $self->minutes,
107             S => $self->seconds,
108             f => $self->frames,
109             r => $self->fps,
110             i => $self->total_frames,
111             s => sprintf("%02d", $self->frames/$self->fps*100),
112             T => $tc,
113             '%'=> '%');
114              
115             # Match printf style formats with optional width and alignment.
116 15         75 ($tc = $format) =~ s/(%-?\d*)([HMSfrisT%])/sprintf "${1}s", $formats{$2}/ge
  20         83  
117             }
118              
119 26         251 $tc;
120             }
121              
122             sub convert
123             {
124 3     3 1 6 my ($self, $fps, $options) = @_;
125              
126 3   100     12 $options ||= {};
127 3         5 $options->{fps} = $fps;
128 3   100     10 $options->{dropframe} ||= 0;
129 3   33     10 $options->{delimiter} ||= $self->{delimiter};
130 3   66     15 $options->{frame_delimiter} ||= $self->{frame_delimiter};
131              
132 3         5 Time::Timecode->new($self->to_non_dropframe->total_frames, $options);
133             }
134              
135             sub to_dropframe
136             {
137 1     1 1 2 my $self = shift;
138 1 50       2 return $self if $self->is_dropframe;
139              
140 1         2 my $options = $self->_dup_options;
141 1         2 $options->{dropframe} = 1;
142              
143 1         2 Time::Timecode->new($self->total_frames, $options);
144             }
145              
146             sub to_non_dropframe
147             {
148 4     4 1 8 my $self = shift;
149 4 100       6 return $self unless $self->is_dropframe;
150              
151 2         5 my $options = $self->_dup_options;
152 2         5 $options->{dropframe} = 0;
153              
154 2         4 Time::Timecode->new($self->total_frames, $options);
155             }
156              
157             sub _add
158             {
159             _handle_binary_overload(@_, sub {
160 5     5   8 $_[0] + $_[1];
161 5     5   17 });
162             }
163              
164             sub _subtract
165             {
166             _handle_binary_overload(@_, sub {
167 4     4   6 $_[0] - $_[1];
168 4     4   19 });
169             }
170              
171             sub _multiply
172             {
173             _handle_binary_overload(@_, sub {
174 1     1   2 $_[0] * $_[1];
175 2     2   8 });
176             }
177              
178             sub _divide
179             {
180             _handle_binary_overload(@_, sub {
181 2     2   5 int($_[0] / $_[1]);
182 2     2   8 });
183             }
184              
185             sub _compare
186             {
187 9     9   21 my ($lhs, $rhs) = _overload_order(@_);
188 9         14 $lhs->total_frames <=> $rhs->total_frames;
189             }
190              
191             sub _overload_order
192             {
193 22     22   31 my ($lhs, $rhs, $reversed) = @_;
194 22 100 66     78 $rhs = Time::Timecode->new($rhs) if !ref($rhs) or !$rhs->isa('Time::Timecode');
195 21 100       32 ($lhs, $rhs) = ($rhs, $lhs) if $reversed;
196 21         40 ($lhs, $rhs);
197             }
198              
199             sub _handle_binary_overload
200             {
201 13     13   14 my $fx = pop @_;
202 13         29 my ($lhs, $rhs) = _overload_order(@_);
203 12         21 Time::Timecode->new($fx->($lhs->total_frames, $rhs->total_frames), $lhs->_dup_options);
204             }
205              
206             sub _dup_options
207             {
208 15     15   21 my $self = shift;
209             { fps => $self->fps,
210             dropframe => $self->is_dropframe,
211             delimiter => $self->{delimiter},
212 15         24 frame_delimiter => $self->{frame_delimiter} };
213             }
214              
215             sub _frames_per_hour
216             {
217 129     129   154 shift->_rounded_fps * $SECONDS_PER_HOUR;
218             }
219              
220             sub _frames_per_minute
221             {
222 181     181   236 shift->_rounded_fps * $SECONDS_PER_MINUTE;
223             }
224              
225             sub _frames
226             {
227 52     52   72 my ($self, $frames) = @_;
228 52         67 $frames % $self->_rounded_fps;
229             }
230              
231             sub _rounded_fps
232             {
233 439     439   447 my $self = shift;
234 439   66     1106 $self->{rounded_fps} ||= POSIX::ceil($self->fps);
235             }
236              
237             sub _hours_from_frames
238             {
239 52     52   63 my ($self, $frames) = @_;
240 52         70 int($frames / $self->_frames_per_hour);
241             }
242              
243             sub _minutes_from_frames
244             {
245 52     52   70 my ($self, $frames) = @_;
246 52         66 int($frames % $self->_frames_per_hour / $self->_frames_per_minute);
247             }
248              
249             sub _seconds_from_frames
250             {
251 52     52   76 my ($self, $frames) = @_;
252 52         63 int($frames % $self->_frames_per_minute / $self->_rounded_fps);
253             }
254              
255             sub _valid_frames
256             {
257 77     77   150 my ($part, $frames, $max) = @_;
258 77 50 33     451 Carp::croak "Invalid frames '$frames': frames must be between 0 and ${ \int($max) }" unless $frames =~ /^\d+$/ && $frames >= 0 && $frames <= $max;
  0   33     0  
259             }
260              
261             sub _valid_time_part
262             {
263 231     231   276 my ($part, $value) = @_;
264 231 100 33     846 Carp::croak "Invalid $part '$value': $part must be between 0 and 59" if !defined($value) || $value < 0 || $value > 59;
      66        
265             }
266              
267             sub _set_and_validate_time_part
268             {
269 308     308   467 my ($self, $part, $value, $validator) = @_;
270 308         416 $validator->($part, $value, $self->fps);
271 307         570 $self->{$part} = int($value); # Can be a string with a 0 prefix: 01, 02, etc...
272             }
273              
274             sub _frames_to_drop {
275 77     77   82 my $self = shift;
276              
277 77 50       122 if (!defined $self->{frames_to_drop}) {
278 77 100       108 $self->{frames_to_drop} = $self->is_dropframe ? POSIX::ceil($self->{fps}*0.066666) : 0;
279             }
280              
281 77         127 $self->{frames_to_drop};
282             }
283              
284             sub _set_and_validate_time
285             {
286 25     25   67 my ($self, $hh, $mm, $ss, $ff) = @_;
287 25         80 $self->_set_and_validate_time_part('frames', $ff, \&_valid_frames);
288 25         55 $self->_set_and_validate_time_part('seconds', $ss, \&_valid_time_part);
289 25         54 $self->_set_and_validate_time_part('minutes', $mm, \&_valid_time_part);
290 25         51 $self->_set_and_validate_time_part('hours', $hh, \&_valid_time_part);
291              
292 25         38 my $total = $self->frames;
293 25         61 $total += $self->_rounded_fps * $ss;
294 25         41 $total += $self->_frames_per_minute * $mm;
295 25         52 $total += $self->_frames_per_hour * $hh;
296              
297 25         32 my $total_minutes = $SECONDS_PER_MINUTE * $hh + $mm;
298 25         51 $total -= $self->_frames_to_drop * ( $total_minutes - int($total_minutes / 10) );
299              
300 25 100       44 Carp::croak "Invalid dropframe timecode: '$self'" unless $self->_valid_dropframe_timecode;
301 24         57 $self->{total_frames} = $total;
302             }
303              
304             sub _valid_dropframe_timecode
305             {
306 25     25   30 my $self = shift;
307 25   66     31 !($self->is_dropframe
308             && $self->seconds == 0
309             && ($self->frames == 0 || $self->frames == 1)
310             && ($self->minutes % 10 != 0));
311             }
312              
313             sub _set_timecode_from_frames
314             {
315 52     52   66 my ($self, $frames) = @_;
316              
317             # We need the true frame rate here, not the rounded
318 52         69 my $fps = $self->{fps};
319              
320             # Support drop frame calculations for known frame rates that don't support them :(
321             # This is in place temporarily for backwards compatibility with $VERSION < 0.30 and will be removed in 0.40
322 52 50       66 if ($self->_is_deprecated_dropframe_rate) {
323 0 0       0 $fps = $self->{fps} == 30 ? 29.97 : 59.94;
324             }
325              
326             #####
327             # Algorithm from: http://www.davidheidelberger.com/blog/?p=29
328 52         78 my $drop = $self->_frames_to_drop;
329              
330 52         75 my $frames_per_ten_minutes = $fps * $SECONDS_PER_MINUTE * 10;
331 52         68 my $frames_per_minute = $self->_frames_per_minute - $drop;
332              
333 52         107 my $d = int($frames / $frames_per_ten_minutes);
334 52         66 my $m = $frames % $frames_per_ten_minutes;
335              
336 52 100       79 if($m > $drop) {
337 49         80 $frames += ($drop * 9 * $d) + $drop * int(($m - $drop) / $frames_per_minute);
338             }
339             else {
340 3         5 $frames += $drop * 9 * $d;
341             }
342             #####
343              
344 52         88 $self->_set_and_validate_time_part('frames', $self->_frames($frames), \&_valid_frames);
345 52         106 $self->_set_and_validate_time_part('seconds', $self->_seconds_from_frames($frames), \&_valid_time_part);
346 52         84 $self->_set_and_validate_time_part('minutes', $self->_minutes_from_frames($frames), \&_valid_time_part);
347 52         93 $self->_set_and_validate_time_part('hours', $self->_hours_from_frames($frames), \&_valid_time_part);
348             }
349              
350             sub _is_deprecated_dropframe_rate
351             {
352 127     127   132 my $self = shift;
353 127 100 33     162 $self->is_dropframe && ($self->{fps} == 30 || $self->{fps} == 60);
354             }
355              
356             sub _timecode_from_total_frames
357             {
358 52     52   85 my ($self, $frames) = @_;
359 52         72 $self->{total_frames} = $frames;
360 52         85 $self->_set_timecode_from_frames($frames);
361             }
362              
363             # Close your eyes, it's about to get ugly...
364             sub _timecode_from_string
365             {
366 12     12   21 my ($self, $timecode) = @_;
367             #[\Q$self->{delimiter}$DEFAULT_DELIMITER\E]
368 12         33 my $delim = '[' . quotemeta("$self->{delimiter}$DEFAULT_DELIMITER") . ']';
369 12         17 my $frame_delim = $FRAME_PART_DELIMITERS;
370              
371 12 100       26 $frame_delim .= $self->{frame_delimiter} if defined $self->{frame_delimiter};
372 12         26 $frame_delim = '[' . quotemeta("$frame_delim") . ']';
373              
374 12 100       404 if($timecode =~ /^\s*($TIME_PART)$delim($TIME_PART)$delim($TIME_PART)($frame_delim)([0-5]\d)\s*([NDPF])?\s*$/) {
375             #TODO: Use suffix after frames to determine drop/non-drop -and possibly other things
376 11 100       36 if(!defined $self->{is_dropframe}) {
377 10 100       67 $self->{is_dropframe} = index($DROP_FRAME_DELIMITERS, $4) != -1 ? 1 : $DEFAULT_DROPFRAME;
378             }
379              
380 11 100       42 $self->{frame_delimiter} = $4 unless defined $self->{frame_delimiter};
381 11         39 $self->_set_and_validate_time($1, $2, $3, $5);
382             }
383             else {
384 1         151 Carp::croak "Can't create timecode from '$timecode'";
385             }
386             }
387              
388             1;
389              
390             __END__