teach interval_to_seconds about HH:MM:SS format time intervals
[OpenSRF.git] / src / perl / lib / OpenSRF / Utils.pm
1 package OpenSRF::Utils;
2
3 =head1 NAME 
4
5 OpenSRF::Utils
6
7 =head1 DESCRIPTION 
8
9 This is a container package for methods that are useful to derived modules.
10 It has no constructor, and is generally not useful by itself... but this
11 is where most of the generic methods live.
12  
13
14 =head1 METHODS 
15
16
17 =cut
18
19 use vars qw/@ISA $AUTOLOAD %EXPORT_TAGS @EXPORT_OK @EXPORT $VERSION/;
20 push @ISA, 'Exporter';
21
22 $VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
23
24 use Time::Local;
25 use Errno;
26 use POSIX;
27 use FileHandle;
28 #use Cache::FileCache;
29 #use Storable qw(dclone);
30 use Digest::MD5 qw(md5 md5_hex md5_base64);
31 use Exporter;
32 use DateTime;
33 use DateTime::Format::ISO8601;
34 use DateTime::TimeZone;
35
36 our $date_parser = DateTime::Format::ISO8601->new;
37
38 # This turns errors into warnings, so daemons don't die.
39 #$Storable::forgive_me = 1;
40
41 %EXPORT_TAGS = (
42         common          => [qw(interval_to_seconds seconds_to_interval sendmail tree_filter)],
43         daemon          => [qw(safe_fork set_psname daemonize)],
44         datetime        => [qw(clense_ISO8601 gmtime_ISO8601 interval_to_seconds seconds_to_interval)],
45 );
46
47 Exporter::export_ok_tags('common','daemon','datetime');  # add aa, cc and dd to @EXPORT_OK
48
49 sub AUTOLOAD {
50         my $self = shift;
51         my $type = ref($self) or return undef;
52
53         my $name = $AUTOLOAD;
54         $name =~ s/.*://;   # strip fully-qualified portion
55
56         if (defined($_[0])) {
57                 return $self->{$name} = shift;
58         }
59         return $self->{$name};
60 }
61
62
63 sub _sub_builder {
64         my $self = shift;
65         my $class = ref($self) || $self;
66         my $part = shift;
67         unless ($class->can($part)) {
68                 *{$class.'::'.$part} =
69                         sub {
70                                 my $self = shift;
71                                 my $new_val = shift;
72                                 if ($new_val) {
73                                         $$self{$part} = $new_val;
74                                 }
75                                 return $$self{$part};
76                 };
77         }
78 }
79
80 sub tree_filter {
81         my $tree = shift;
82         my $field = shift;
83         my $filter = shift;
84
85         my @things = $filter->($tree);
86         for my $v ( @{$tree->$field} ){
87                 push @things, $filter->($v);
88                 push @things, tree_filter($v, $field, $filter);
89         }
90         return @things
91 }
92
93 #sub standalone_ipc_cache {
94 #       my $self = shift;
95 #       my $class = ref($self) || $self;
96 #       my $uniquifier = shift || return undef;
97 #       my $expires = shift || 3600;
98
99 #       return new Cache::FileCache ( { namespace => $class.'::'.$uniquifier, default_expires_in => $expires } );
100 #}
101
102 sub sendmail {
103         my $self = shift;
104         my $message = shift || $self;
105
106         open SM, '|/usr/sbin/sendmail -U -t' or return 0;
107         print SM $message;
108         close SM or return 0;
109         return 1;
110 }
111
112 sub __strip_comments {
113         my $self = shift;
114         my $config_file = shift;
115         my ($line, @done);
116         while (<$config_file>) {
117                 s/^\s*(.*)\s*$/$1/o if (lc($$self{keep_space}) ne 'true');
118                 /^(.*)$/o;
119                 $line .= $1;
120                 # keep new lines if keep_space is true
121                 if ($line =~ /^$/o && (lc($$self{keep_space}) ne 'true')) {
122                         $line = '';
123                         next;
124                 }
125                 if (/^([^<]+)\s*<<\s*(\w+)\s*$/o) {
126                         $line = "$1 = ";
127                         my $breaker = $2;
128                         while (<$config_file>) {
129                                 chomp;
130                                 last if (/^$breaker/);
131                                 $line .= $_;
132                         }
133                 }
134
135                 if ($line =~ /^#/ && $line !~ /^#\s*include\s+/o) {
136                         $line = '';
137                         next;
138                 }
139                 if ($line =~ /\\$/o) {
140                         chomp $line;
141                         $line =~ s/^\s*(.*)\s*\\$/$1/o;
142                         next;
143                 }
144                 push @done, $line;
145                 $line = '';
146         }
147         return @done;
148 }
149
150
151 =head2 $thing->encrypt(@stuff)
152
153 Returns a one way hash (MD5) of the values appended together.
154
155 =cut
156
157 sub encrypt {
158         my $self = shift;
159         return md5_hex(join('',@_));
160 }
161
162 =head2 $utils_obj->es_time('field') OR noo_es_time($timestamp)
163
164 Returns the epoch-second style timestamp for the value stored in
165 $utils_obj->{field}.  Returns B<0> for an empty or invalid date stamp, and
166 assumes a PostgreSQL style datestamp to be supplied.
167
168 =cut
169
170 sub es_time {
171         my $self = shift;
172         my $part = shift;
173         my $es_part = $part.'_ES';
174         return $$self{$es_part} if (exists($$self{$es_part}) && defined($$self{$es_part}) && $$self{$es_part});
175         if (!$$self{$part} or $$self{$part} !~ /\d+/) {
176                 return 0;
177
178         }
179         my @tm = reverse($$self{$part} =~ /([\d\.]+)/og);
180         if ($tm[5] > 0) {
181                 $tm[5] -= 1;
182         }
183
184         return $$self{$es_part} = noo_es_time($$self{$part});
185 }
186
187 =head2 noo_es_time($timestamp) (non-OO es_time)
188
189 Returns the epoch-second style timestamp for the B<$timestamp> passed
190 in.  Returns B<0> for an empty or invalid date stamp, and
191 assumes a PostgreSQL style datestamp to be supplied.
192
193 =cut
194
195 sub noo_es_time {
196         my $timestamp = shift;
197
198         my @tm = reverse($timestamp =~ /([\d\.]+)/og);
199         if ($tm[5] > 0) {
200                 $tm[5] -= 1;
201         }
202         return timelocal(int($tm[1]), int($tm[2]), int($tm[3]), int($tm[4]) || 1, int($tm[5]), int($tm[6]) || 2002 );
203 }
204
205
206 =head2 $thing->interval_to_seconds('interval') OR interval_to_seconds('interval')
207
208 =head2 $thing->seconds_to_interval($seconds) OR seconds_to_interval($seconds)
209
210 Returns the number of seconds for any interval passed, or the interval for the seconds.
211 This is the generic version of B<interval> listed below.
212
213 The interval must match the regex I</\s*\+?\s*(\d+)\s*(\w{1})\w*\s*/g>, for example
214 B<2 weeks, 3 d and 1hour + 17 Months> or
215 B<1 year, 5 Months, 2 weeks, 3 days and 1 hour of seconds> meaning 46148400 seconds.
216
217         my $expire_time = time() + $thing->interval_to_seconds('17h 9m');
218
219 The time size indicator may be one of
220
221 =over 2
222
223 =item s[econd[s]]
224
225 for seconds
226
227 =item m[inute[s]]
228
229 for minutes
230
231 =item h[our[s]]
232
233 for hours
234
235 =item d[ay[s]]
236
237 for days
238
239 =item w[eek[s]]
240
241 for weeks
242
243 =item M[onth[s]]
244
245 for months (really (365 * 1d)/12 ... that may get smarter, though)
246
247 =item y[ear[s]]
248
249 for years (this is 365 * 1d)
250
251 =back
252
253 =cut
254 sub interval_to_seconds {
255         my $self = shift;
256         my $interval = shift || $self;
257
258         $interval =~ s/(\d{2}):(\d{2}):(\d{2})/ $1 h $2 min $3 s /go;
259
260         $interval =~ s/and/,/g;
261         $interval =~ s/,/ /g;
262
263         my $amount = 0;
264         while ($interval =~ /\s*([\+-]?)\s*(\d+)\s*(\w+)\s*/g) {
265                 my ($sign, $count, $type) = ($1, $2, $3);
266                 $count = "$sign$count" if ($sign);
267                 $amount += $count if ($type eq 's');
268                 $amount += 60 * $count if ($type =~ /^m(?!o)/oi);
269                 $amount += 60 * 60 * $count if ($type =~ /^h/);
270                 $amount += 60 * 60 * 24 * $count if ($type =~ /^d/oi);
271                 $amount += 60 * 60 * 24 * 7 * $count if ($2 =~ /^w/oi);
272                 $amount += ((60 * 60 * 24 * 365)/12) * $count if ($type =~ /^mo/io);
273                 $amount += 60 * 60 * 24 * 365 * $count if ($type =~ /^y/oi);
274         }
275         return $amount;
276 }
277
278 sub seconds_to_interval {
279         my $self = shift;
280         my $interval = shift || $self;
281
282         my $limit = shift || 's';
283         $limit =~ s/^(.)/$1/o;
284
285         my ($y,$ym,$M,$Mm,$w,$wm,$d,$dm,$h,$hm,$m,$mm,$s,$string);
286         my ($year, $month, $week, $day, $hour, $minute, $second) =
287                 ('year','Month','week','day', 'hour', 'minute', 'second');
288
289         if ($y = int($interval / (60 * 60 * 24 * 365))) {
290                 $string = "$y $year". ($y > 1 ? 's' : '');
291                 $ym = $interval % (60 * 60 * 24 * 365);
292         } else {
293                 $ym = $interval;
294         }
295         return $string if ($limit eq 'y');
296
297         if ($M = int($ym / ((60 * 60 * 24 * 365)/12))) {
298                 $string .= ($string ? ', ':'')."$M $month". ($M > 1 ? 's' : '');
299                 $Mm = $ym % ((60 * 60 * 24 * 365)/12);
300         } else {
301                 $Mm = $ym;
302         }
303         return $string if ($limit eq 'M');
304
305         if ($w = int($Mm / 604800)) {
306                 $string .= ($string ? ', ':'')."$w $week". ($w > 1 ? 's' : '');
307                 $wm = $Mm % 604800;
308         } else {
309                 $wm = $Mm;
310         }
311         return $string if ($limit eq 'w');
312
313         if ($d = int($wm / 86400)) {
314                 $string .= ($string ? ', ':'')."$d $day". ($d > 1 ? 's' : '');
315                 $dm = $wm % 86400;
316         } else {
317                 $dm = $wm;
318         }
319         return $string if ($limit eq 'd');
320
321         if ($h = int($dm / 3600)) {
322                 $string .= ($string ? ', ' : '')."$h $hour". ($h > 1 ? 's' : '');
323                 $hm = $dm % 3600;
324         } else {
325                 $hm = $dm;
326         }
327         return $string if ($limit eq 'h');
328
329         if ($m = int($hm / 60)) {
330                 $string .= ($string ? ', ':'')."$m $minute". ($m > 1 ? 's' : '');
331                 $mm = $hm % 60;
332         } else {
333                 $mm = $hm;
334         }
335         return $string if ($limit eq 'm');
336
337         if ($s = int($mm)) {
338                 $string .= ($string ? ', ':'')."$s $second". ($s > 1 ? 's' : '');
339         } else {
340                 $string = "0s" unless ($string);
341         }
342         return $string;
343 }
344
345 sub full {
346         my $self = shift;
347         $$self{empty} = 0;
348 }
349
350 =head2 $utils_obj->set_psname('string') OR set_psname('string')
351
352 Sets the name of this process in a B<ps> listing to B<string>.
353
354
355 =cut
356
357 sub set_psname {
358         my $self = shift;
359         my $PS_NAME = shift || $self;
360         $0 = $PS_NAME if ($PS_NAME);
361 }
362
363 sub gmtime_ISO8601 {
364         my $self = shift;
365         my @date = gmtime;
366
367         my $y = $date[5] + 1900;
368         my $M = $date[4] + 1;
369         my $d = $date[3];
370         my $h = $date[2];
371         my $m = $date[1];
372         my $s = $date[0];
373
374         return sprintf('%d-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d+00:00', $y, $M, $d, $h, $m, $s);
375 }
376
377 sub clense_ISO8601 {
378         my $self = shift;
379         my $date = shift || $self;
380         if ($date =~ /^\s*(\d{4})-?(\d{2})-?(\d{2})/o) {
381                 my $new_date = "$1-$2-$3";
382
383                 if ($date =~/(\d{2}):(\d{2}):(\d{2})/o) {
384                         $new_date .= "T$1:$2:$3";
385
386                         my $z;
387                         if ($date =~ /([-+]{1})([0-9]{1,2})(?::?([0-9]{1,2}))*\s*$/o) {
388                                 $z = sprintf('%s%0.2d%0.2d',$1,$2,$3)
389                         } else {
390                                 $z =  DateTime::TimeZone::offset_as_string(
391                                         DateTime::TimeZone
392                                                 ->new( name => 'local' )
393                                                 ->offset_for_datetime(
394                                                         $date_parser->parse_datetime($new_date)
395                                                 )
396                                 );
397                         }
398
399                         if (length($z) > 3 && index($z, ':') == -1) {
400                                 substr($z,3,0) = ':';
401                                 substr($z,6,0) = ':' if (length($z) > 6);
402                         }
403                 
404                         $new_date .= $z;
405                 } else {
406                         $new_date .= "T00:00:00";
407                 }
408
409                 return $new_date;
410         }
411         return $date;
412 }
413
414 =head2 $utils_obj->daemonize('ps_name') OR daemonize('ps_name')
415
416 Turns the current process into a daemon.  B<ps_name> is optional, and is used
417 as the argument to I<< set_psname() >> if passed.
418
419
420 =cut
421
422 sub daemonize {
423         my $self = shift;
424         my $PS_NAME = shift || $self;
425         my $pid;
426         if ($pid = safe_fork($self)) {
427                 exit 0;
428         } elsif (defined($pid)) {
429                 set_psname($PS_NAME);
430                 chdir '/';
431                 setsid;
432                 return $$;
433         }
434 }
435
436 =head2 $utils_obj->safe_fork('ps_name') OR safe_fork('ps_name');
437
438 Forks the current process in a retry loop.  B<ps_name> is optional, and is used
439 as the argument to I<< set_psname() >> if passed.
440
441
442 =cut
443
444 sub safe_fork {
445         my $self = shift;
446         my $pid;
447
448 FORK:
449         {
450                 if (defined($pid = fork())) {
451                         srand(time ^ ($$ + ($$ << 15))) unless ($pid);
452                         return $pid;
453                 } elsif ($! == EAGAIN) {
454                         $self->error("Can't fork()!  $!, taking 5 and trying again.") if (ref $self);
455                         sleep 5;
456                         redo FORK;
457                 } else {
458                         $self->error("Can't fork()! $!") if ($! && ref($self));
459                         exit $!;
460                 }
461         }
462 }
463
464 #------------------------------------------------------------------------------------------------------------------------------------
465
466
467 1;