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