File Coverage

File:blib/lib/OpenSRF/Utils.pm
Coverage:11.1%

linestmtbrancondsubpodtimecode
1package OpenSRF::Utils;
2
3
14
14
14
14
139
75
228
use Time::Local;
4
14
14
14
14
155
53
154
use Errno;
5
14
14
14
14
162
63
142
use POSIX;
6
14
14
14
14
128
51
120
use FileHandle;
7
14
14
14
14
99
49
117
use Digest::MD5 qw(md5 md5_hex md5_base64);
8
14
14
14
14
88
50
321
use Exporter;
9
14
14
14
14
190
109
108
use DateTime;
10
14
14
14
14
240
66
203
use DateTime::Format::ISO8601;
11
14
14
14
14
162
48
137
use DateTime::TimeZone;
12
13 - 25
=head1 NAME

OpenSRF::Utils

=head1 DESCRIPTION

This is a container package for methods that are useful to derived modules.
It has no constructor, and is generally not useful by itself... but this
is where most of the generic methods live.

=head1 VERSION

=cut
26
27our $VERSION = 1.000;
28
29
14
14
14
14
101
48
103
use vars qw/@ISA $AUTOLOAD %EXPORT_TAGS @EXPORT_OK @EXPORT/;
30push @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 gmtime_ISO8601 interval_to_seconds seconds_to_interval)],
36);
37Exporter::export_ok_tags('common','daemon','datetime'); # add aa, cc and dd to @EXPORT_OK
38
39our $date_parser = DateTime::Format::ISO8601->new;
40
41 - 44
=head1 METHODS


=cut
45
46sub AUTOLOAD {
47
0
0
        my $self = shift;
48
0
0
        my $type = ref($self) or return undef;
49
50
0
        my $name = $AUTOLOAD;
51
0
        $name =~ s/.*://; # strip fully-qualified portion
52
53
0
0
        if (defined($_[0])) {
54
0
                return $self->{$name} = shift;
55        }
56
0
        return $self->{$name};
57}
58
59
60sub _sub_builder {
61
0
0
        my $self = shift;
62
0
0
        my $class = ref($self) || $self;
63
0
        my $part = shift;
64
0
0
        unless ($class->can($part)) {
65
0
                *{$class.'::'.$part} =
66                        sub {
67
0
0
                                my $self = shift;
68
0
                                my $new_val = shift;
69
0
0
                                if ($new_val) {
70
0
                                        $$self{$part} = $new_val;
71                                }
72
0
                                return $$self{$part};
73
0
                };
74        }
75}
76
77sub tree_filter {
78
0
0
0
        my $tree = shift;
79
0
        my $field = shift;
80
0
        my $filter = shift;
81
82
0
        my @things = $filter->($tree);
83
0
0
        for my $v ( @{$tree->$field} ){
84
0
                push @things, $filter->($v);
85
0
                push @things, tree_filter($v, $field, $filter);
86        }
87        return @things
88
0
}
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
99sub sendmail {
100
0
0
0
        my $self = shift;
101
0
0
        my $message = shift || $self;
102
103
0
0
        open SM, '|/usr/sbin/sendmail -U -t' or return 0;
104
0
        print SM $message;
105
0
0
        close SM or return 0;
106
0
        return 1;
107}
108
109sub __strip_comments {
110
0
0
        my $self = shift;
111
0
        my $config_file = shift;
112
0
        my ($line, @done);
113
0
        while (<$config_file>) {
114
0
0
                s/^\s*(.*)\s*$/$1/o if (lc($$self{keep_space}) ne 'true');
115
0
                /^(.*)$/o;
116
0
                $line .= $1;
117                # keep new lines if keep_space is true
118
0
0
0
                if ($line =~ /^$/o && (lc($$self{keep_space}) ne 'true')) {
119
0
                        $line = '';
120
0
                        next;
121                }
122
0
0
                if (/^([^<]+)\s*<<\s*(\w+)\s*$/o) {
123
0
                        $line = "$1 = ";
124
0
                        my $breaker = $2;
125
0
                        while (<$config_file>) {
126
0
                                chomp;
127
0
0
                                last if (/^$breaker/);
128
0
                                $line .= $_;
129                        }
130                }
131
132
0
0
0
                if ($line =~ /^#/ && $line !~ /^#\s*include\s+/o) {
133
0
                        $line = '';
134
0
                        next;
135                }
136
0
0
                if ($line =~ /\\$/o) {
137
0
                        chomp $line;
138
0
                        $line =~ s/^\s*(.*)\s*\\$/$1/o;
139
0
                        next;
140                }
141
0
                push @done, $line;
142
0
                $line = '';
143        }
144
0
        return @done;
145}
146
147
148 - 152
=head2 $thing->encrypt(@stuff)

Returns a one way hash (MD5) of the values appended together.

=cut
153
154sub encrypt {
155
0
0
1
        my $self = shift;
156
0
        return md5_hex(join('',@_));
157}
158
159 - 165
=head2 $utils_obj->es_time('field') OR noo_es_time($timestamp)

Returns the epoch-second style timestamp for the value stored in
$utils_obj->{field}.  Returns B<0> for an empty or invalid date stamp, and
assumes a PostgreSQL style datestamp to be supplied.

=cut
166
167sub es_time {
168
0
0
1
        my $self = shift;
169
0
        my $part = shift;
170
0
        my $es_part = $part.'_ES';
171
0
0
0
        return $$self{$es_part} if (exists($$self{$es_part}) && defined($$self{$es_part}) && $$self{$es_part});
172
0
0
0
        if (!$$self{$part} or $$self{$part} !~ /\d+/) {
173
0
                return 0;
174
175        }
176
0
        my @tm = reverse($$self{$part} =~ /([\d\.]+)/og);
177
0
0
        if ($tm[5] > 0) {
178
0
                $tm[5] -= 1;
179        }
180
181
0
        return $$self{$es_part} = noo_es_time($$self{$part});
182}
183
184 - 190
=head2 noo_es_time($timestamp) (non-OO es_time)

Returns the epoch-second style timestamp for the B<$timestamp> passed
in.  Returns B<0> for an empty or invalid date stamp, and
assumes a PostgreSQL style datestamp to be supplied.

=cut
191
192sub noo_es_time {
193
0
0
1
        my $timestamp = shift;
194
195
0
        my @tm = reverse($timestamp =~ /([\d\.]+)/og);
196
0
0
        if ($tm[5] > 0) {
197
0
                $tm[5] -= 1;
198        }
199
0
0
0
        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 - 250
=head2 $thing->interval_to_seconds('interval') OR interval_to_seconds('interval')

=head2 $thing->seconds_to_interval($seconds) OR seconds_to_interval($seconds)

Returns the number of seconds for any interval passed, or the interval for the seconds.
This is the generic version of B<interval> listed below.

The interval must match the regex I</\s*\+?\s*(\d+)\s*(\w{1})\w*\s*/g>, for example
B<2 weeks, 3 d and 1hour + 17 Months> or
B<1 year, 5 Months, 2 weeks, 3 days and 1 hour of seconds> meaning 46148400 seconds.

	my $expire_time = time() + $thing->interval_to_seconds('17h 9m');

The time size indicator may be one of

=over 2

=item s[econd[s]]

for seconds

=item m[inute[s]]

for minutes

=item h[our[s]]

for hours

=item d[ay[s]]

for days

=item w[eek[s]]

for weeks

=item M[onth[s]]

for months (really (365 * 1d)/12 ... that may get smarter, though)

=item y[ear[s]]

for years (this is 365 * 1d)

=back

=cut
251sub interval_to_seconds {
252
0
0
1
        my $self = shift;
253
0
0
        my $interval = shift || $self;
254
255
0
        $interval =~ s/(\d{2}):(\d{2}):(\d{2})/ $1 h $2 min $3 s /go;
256
257
0
        $interval =~ s/and/,/g;
258
0
        $interval =~ s/,/ /g;
259
260
0
        my $amount = 0;
261
0
        while ($interval =~ /\s*([\+-]?)\s*(\d+)\s*(\w+)\s*/g) {
262
0
                my ($sign, $count, $type) = ($1, $2, $3);
263
0
0
                $count = "$sign$count" if ($sign);
264
0
0
                $amount += $count if ($type eq 's');
265
0
0
                $amount += 60 * $count if ($type =~ /^m(?!o)/oi);
266
0
0
                $amount += 60 * 60 * $count if ($type =~ /^h/);
267
0
0
                $amount += 60 * 60 * 24 * $count if ($type =~ /^d/oi);
268
0
0
                $amount += 60 * 60 * 24 * 7 * $count if ($2 =~ /^w/oi);
269
0
0
                $amount += ((60 * 60 * 24 * 365)/12) * $count if ($type =~ /^mo/io);
270
0
0
                $amount += 60 * 60 * 24 * 365 * $count if ($type =~ /^y/oi);
271        }
272
0
        return $amount;
273}
274
275sub seconds_to_interval {
276
0
0
1
        my $self = shift;
277
0
0
        my $interval = shift || $self;
278
279
0
0
        my $limit = shift || 's';
280
0
        $limit =~ s/^(.)/$1/o;
281
282
0
        my ($y,$ym,$M,$Mm,$w,$wm,$d,$dm,$h,$hm,$m,$mm,$s,$string);
283
0
        my ($year, $month, $week, $day, $hour, $minute, $second) =
284                ('year','Month','week','day', 'hour', 'minute', 'second');
285
286
0
0
        if ($y = int($interval / (60 * 60 * 24 * 365))) {
287
0
0
                $string = "$y $year". ($y > 1 ? 's' : '');
288
0
                $ym = $interval % (60 * 60 * 24 * 365);
289        } else {
290
0
                $ym = $interval;
291        }
292
0
0
        return $string if ($limit eq 'y');
293
294
0
0
        if ($M = int($ym / ((60 * 60 * 24 * 365)/12))) {
295
0
0
0
                $string .= ($string ? ', ':'')."$M $month". ($M > 1 ? 's' : '');
296
0
                $Mm = $ym % ((60 * 60 * 24 * 365)/12);
297        } else {
298
0
                $Mm = $ym;
299        }
300
0
0
        return $string if ($limit eq 'M');
301
302
0
0
        if ($w = int($Mm / 604800)) {
303
0
0
0
                $string .= ($string ? ', ':'')."$w $week". ($w > 1 ? 's' : '');
304
0
                $wm = $Mm % 604800;
305        } else {
306
0
                $wm = $Mm;
307        }
308
0
0
        return $string if ($limit eq 'w');
309
310
0
0
        if ($d = int($wm / 86400)) {
311
0
0
0
                $string .= ($string ? ', ':'')."$d $day". ($d > 1 ? 's' : '');
312
0
                $dm = $wm % 86400;
313        } else {
314
0
                $dm = $wm;
315        }
316
0
0
        return $string if ($limit eq 'd');
317
318
0
0
        if ($h = int($dm / 3600)) {
319
0
0
0
                $string .= ($string ? ', ' : '')."$h $hour". ($h > 1 ? 's' : '');
320
0
                $hm = $dm % 3600;
321        } else {
322
0
                $hm = $dm;
323        }
324
0
0
        return $string if ($limit eq 'h');
325
326
0
0
        if ($m = int($hm / 60)) {
327
0
0
0
                $string .= ($string ? ', ':'')."$m $minute". ($m > 1 ? 's' : '');
328
0
                $mm = $hm % 60;
329        } else {
330
0
                $mm = $hm;
331        }
332
0
0
        return $string if ($limit eq 'm');
333
334
0
0
        if ($s = int($mm)) {
335
0
0
0
                $string .= ($string ? ', ':'')."$s $second". ($s > 1 ? 's' : '');
336        } else {
337
0
0
                $string = "0s" unless ($string);
338        }
339
0
        return $string;
340}
341
342sub full {
343
0
0
0
        my $self = shift;
344
0
        $$self{empty} = 0;
345}
346
347 - 352
=head2 $utils_obj->set_psname('string') OR set_psname('string')

Sets the name of this process in a B<ps> listing to B<string>.


=cut
353
354sub set_psname {
355
0
0
1
        my $self = shift;
356
0
0
        my $PS_NAME = shift || $self;
357
0
0
        $0 = $PS_NAME if ($PS_NAME);
358}
359
360sub gmtime_ISO8601 {
361
0
0
0
        my $self = shift;
362
0
        my @date = gmtime;
363
364
0
        my $y = $date[5] + 1900;
365
0
        my $M = $date[4] + 1;
366
0
        my $d = $date[3];
367
0
        my $h = $date[2];
368
0
        my $m = $date[1];
369
0
        my $s = $date[0];
370
371
0
        return sprintf('%d-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d+00:00', $y, $M, $d, $h, $m, $s);
372}
373
374sub clense_ISO8601 {
375
0
0
0
        my $self = shift;
376
0
0
        my $date = shift || $self;
377
0
0
        if ($date =~ /^\s*(\d{4})-?(\d{2})-?(\d{2})/o) {
378
0
                my $new_date = "$1-$2-$3";
379
380
0
0
                if ($date =~/(\d{2}):(\d{2}):(\d{2})/o) {
381
0
                        $new_date .= "T$1:$2:$3";
382
383
0
                        my $z;
384
0
0
                        if ($date =~ /([-+]{1})([0-9]{1,2})(?::?([0-9]{1,2}))*\s*$/o) {
385
0
                                $z = sprintf('%s%0.2d%0.2d',$1,$2,$3)
386                        } else {
387
0
                                $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
0
0
0
                        if (length($z) > 3 && index($z, ':') == -1) {
397
0
                                substr($z,3,0) = ':';
398
0
0
                                substr($z,6,0) = ':' if (length($z) > 6);
399                        }
400
401
0
                        $new_date .= $z;
402                } else {
403
0
                        $new_date .= "T00:00:00";
404                }
405
406
0
                return $new_date;
407        }
408
0
        return $date;
409}
410
411 - 417
=head2 $utils_obj->daemonize('ps_name') OR daemonize('ps_name')

Turns the current process into a daemon.  B<ps_name> is optional, and is used
as the argument to I<< set_psname() >> if passed.


=cut
418
419sub daemonize {
420
0
0
1
        my $self = shift;
421
0
0
        my $PS_NAME = shift || $self;
422
0
        my $pid;
423
0
0
0
        if ($pid = safe_fork($self)) {
424
0
                exit 0;
425        } elsif (defined($pid)) {
426
0
                set_psname($PS_NAME);
427
0
                chdir '/';
428
0
                setsid;
429
0
                return $$;
430        }
431}
432
433 - 439
=head2 $utils_obj->safe_fork('ps_name') OR safe_fork('ps_name');

Forks the current process in a retry loop.  B<ps_name> is optional, and is used
as the argument to I<< set_psname() >> if passed.


=cut
440
441sub safe_fork {
442
0
0
1
        my $self = shift;
443
0
        my $pid;
444
445FORK:
446        {
447
0
0
0
0
                if (defined($pid = fork())) {
448
0
0
                        srand(time ^ ($$ + ($$ << 15))) unless ($pid);
449
0
                        return $pid;
450                } elsif ($! == EAGAIN) {
451
0
0
                        $self->error("Can't fork()! $!, taking 5 and trying again.") if (ref $self);
452
0
                        sleep 5;
453
0
                        redo FORK;
454                } else {
455
0
0
0
                        $self->error("Can't fork()! $!") if ($! && ref($self));
456
0
                        exit $!;
457                }
458        }
459}
460
461#------------------------------------------------------------------------------------------------------------------------------------
462
463
4641;