af9e3b9dc3e8fa4ebfac910c78dd5b38a1494228
[Evergreen.git] / OpenSRF / src / perlmods / 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
33 # This turns errors into warnings, so daemons don't die.
34 #$Storable::forgive_me = 1;
35
36 %EXPORT_TAGS = (
37         common          => [qw(interval_to_seconds seconds_to_interval sendmail)],
38         daemon          => [qw(safe_fork set_psname daemonize)],
39         datetime        => [qw(clense_ISO8601 interval_to_seconds seconds_to_interval)],
40 );
41
42 Exporter::export_ok_tags('common','daemon','datetime');  # add aa, cc and dd to @EXPORT_OK
43
44 sub AUTOLOAD {
45         my $self = shift;
46         my $type = ref($self) or return undef;
47
48         my $name = $AUTOLOAD;
49         $name =~ s/.*://;   # strip fully-qualified portion
50
51         if (defined($_[0])) {
52                 return $self->{$name} = shift;
53         }
54         return $self->{$name};
55 }
56
57
58 sub _sub_builder {
59         my $self = shift;
60         my $class = ref($self) || $self;
61         my $part = shift;
62         unless ($class->can($part)) {
63                 *{$class.'::'.$part} =
64                         sub {
65                                 my $self = shift;
66                                 my $new_val = shift;
67                                 if ($new_val) {
68                                         $$self{$part} = $new_val;
69                                 }
70                                 return $$self{$part};
71                 };
72         }
73 }
74
75 #sub standalone_ipc_cache {
76 #       my $self = shift;
77 #       my $class = ref($self) || $self;
78 #       my $uniquifier = shift || return undef;
79 #       my $expires = shift || 3600;
80
81 #       return new Cache::FileCache ( { namespace => $class.'::'.$uniquifier, default_expires_in => $expires } );
82 #}
83
84 sub sendmail {
85         my $self = shift;
86         my $message = shift || $self;
87
88         open SM, '|/usr/sbin/sendmail -U -t' or return 0;
89         print SM $message;
90         close SM or return 0;
91         return 1;
92 }
93
94 sub __strip_comments {
95         my $self = shift;
96         my $config_file = shift;
97         my ($line, @done);
98         while (<$config_file>) {
99                 s/^\s*(.*)\s*$/$1/o if (lc($$self{keep_space}) ne 'true');
100                 /^(.*)$/o;
101                 $line .= $1;
102                 # keep new lines if keep_space is true
103                 if ($line =~ /^$/o && (lc($$self{keep_space}) ne 'true')) {
104                         $line = '';
105                         next;
106                 }
107                 if (/^([^<]+)\s*<<\s*(\w+)\s*$/o) {
108                         $line = "$1 = ";
109                         my $breaker = $2;
110                         while (<$config_file>) {
111                                 chomp;
112                                 last if (/^$breaker/);
113                                 $line .= $_;
114                         }
115                 }
116
117                 if ($line =~ /^#/ && $line !~ /^#\s*include\s+/o) {
118                         $line = '';
119                         next;
120                 }
121                 if ($line =~ /\\$/o) {
122                         chomp $line;
123                         $line =~ s/^\s*(.*)\s*\\$/$1/o;
124                         next;
125                 }
126                 push @done, $line;
127                 $line = '';
128         }
129         return @done;
130 }
131
132
133 =head2 $thing->encrypt(@stuff)
134
135 Returns a one way hash (MD5) of the values appended together.
136
137 =cut
138
139 sub encrypt {
140         my $self = shift;
141         return md5_hex(join('',@_));
142 }
143
144 =head2 $utils_obj->es_time('field') OR noo_es_time($timestamp)
145
146 Returns the epoch-second style timestamp for the value stored in
147 $utils_obj->{field}.  Returns B<0> for an empty or invalid date stamp, and
148 assumes a PostgreSQL style datestamp to be supplied.
149
150 =cut
151
152 sub es_time {
153         my $self = shift;
154         my $part = shift;
155         my $es_part = $part.'_ES';
156         return $$self{$es_part} if (exists($$self{$es_part}) && defined($$self{$es_part}) && $$self{$es_part});
157         if (!$$self{$part} or $$self{$part} !~ /\d+/) {
158                 return 0;
159
160         }
161         my @tm = reverse($$self{$part} =~ /([\d\.]+)/og);
162         if ($tm[5] > 0) {
163                 $tm[5] -= 1;
164         }
165
166         return $$self{$es_part} = noo_es_time($$self{$part});
167 }
168
169 =head2 noo_es_time($timestamp) (non-OO es_time)
170
171 Returns the epoch-second style timestamp for the B<$timestamp> passed
172 in.  Returns B<0> for an empty or invalid date stamp, and
173 assumes a PostgreSQL style datestamp to be supplied.
174
175 =cut
176
177 sub noo_es_time {
178         my $timestamp = shift;
179
180         my @tm = reverse($timestamp =~ /([\d\.]+)/og);
181         if ($tm[5] > 0) {
182                 $tm[5] -= 1;
183         }
184         return timelocal(int($tm[1]), int($tm[2]), int($tm[3]), int($tm[4]) || 1, int($tm[5]), int($tm[6]) || 2002 );
185 }
186
187
188 =head2 $thing->interval_to_seconds('interval') OR interval_to_seconds('interval')
189
190 =head2 $thing->seconds_to_interval($seconds) OR seconds_to_interval($seconds)
191
192 Returns the number of seconds for any interval passed, or the interval for the seconds.
193 This is the generic version of B<interval> listed below.
194
195 The interval must match the regex I</\s*\+?\s*(\d+)\s*(\w{1})\w*\s*/g>, for example
196 B<2 weeks, 3 d and 1hour + 17 Months> or
197 B<1 year, 5 Months, 2 weeks, 3 days and 1 hour of seconds> meaning 46148400 seconds.
198
199         my $expire_time = time() + $thing->interval_to_seconds('17h 9m');
200
201 The time size indicator may be one of
202
203 =over 2
204
205 =item s[econd[s]]
206
207 for seconds
208
209 =item m[inute[s]]
210
211 for minutes
212
213 =item h[our[s]]
214
215 for hours
216
217 =item d[ay[s]]
218
219 for days
220
221 =item w[eek[s]]
222
223 for weeks
224
225 =item M[onth[s]]
226
227 for months (really (365 * 1d)/12 ... that may get smarter, though)
228
229 =item y[ear[s]]
230
231 for years (this is 365 * 1d)
232
233 =back
234
235 =cut
236 sub interval_to_seconds {
237         my $self = shift;
238         my $interval = shift || $self;
239
240         $interval =~ s/and/,/g;
241         $interval =~ s/,/ /g;
242
243         my $amount = 0;
244         while ($interval =~ /\s*\+?\s*(\d+)\s*(\w{1})\w*\s*/g) {
245                 $amount += $1 if ($2 eq 's');
246                 $amount += 60 * $1 if ($2 eq 'm');
247                 $amount += 60 * 60 * $1 if ($2 eq 'h');
248                 $amount += 60 * 60 * 24 * $1 if ($2 eq 'd');
249                 $amount += 60 * 60 * 24 * 7 * $1 if ($2 eq 'w');
250                 $amount += ((60 * 60 * 24 * 365)/12) * $1 if ($2 eq 'M');
251                 $amount += 60 * 60 * 24 * 365 * $1 if ($2 eq 'y');
252         }
253         return $amount;
254 }
255
256 sub seconds_to_interval {
257         my $self = shift;
258         my $interval = shift || $self;
259
260         my $limit = shift || 's';
261         $limit =~ s/^(.)/$1/o;
262
263         my ($y,$ym,$M,$Mm,$w,$wm,$d,$dm,$h,$hm,$m,$mm,$s,$string);
264         my ($year, $month, $week, $day, $hour, $minute, $second) =
265                 ('year','Month','week','day', 'hour', 'minute', 'second');
266
267         if ($y = int($interval / (60 * 60 * 24 * 365))) {
268                 $string = "$y $year". ($y > 1 ? 's' : '');
269                 $ym = $interval % (60 * 60 * 24 * 365);
270         } else {
271                 $ym = $interval;
272         }
273         return $string if ($limit eq 'y');
274
275         if ($M = int($ym / ((60 * 60 * 24 * 365)/12))) {
276                 $string .= ($string ? ', ':'')."$M $month". ($M > 1 ? 's' : '');
277                 $Mm = $ym % ((60 * 60 * 24 * 365)/12);
278         } else {
279                 $Mm = $ym;
280         }
281         return $string if ($limit eq 'M');
282
283         if ($w = int($Mm / 604800)) {
284                 $string .= ($string ? ', ':'')."$w $week". ($w > 1 ? 's' : '');
285                 $wm = $Mm % 604800;
286         } else {
287                 $wm = $Mm;
288         }
289         return $string if ($limit eq 'w');
290
291         if ($d = int($wm / 86400)) {
292                 $string .= ($string ? ', ':'')."$d $day". ($d > 1 ? 's' : '');
293                 $dm = $wm % 86400;
294         } else {
295                 $dm = $wm;
296         }
297         return $string if ($limit eq 'd');
298
299         if ($h = int($dm / 3600)) {
300                 $string .= ($string ? ', ' : '')."$h $hour". ($h > 1 ? 's' : '');
301                 $hm = $dm % 3600;
302         } else {
303                 $hm = $dm;
304         }
305         return $string if ($limit eq 'h');
306
307         if ($m = int($hm / 60)) {
308                 $string .= ($string ? ', ':'')."$m $minute". ($m > 1 ? 's' : '');
309                 $mm = $hm % 60;
310         } else {
311                 $mm = $hm;
312         }
313         return $string if ($limit eq 'm');
314
315         if ($s = int($mm)) {
316                 $string .= ($string ? ', ':'')."$s $second". ($s > 1 ? 's' : '');
317         } else {
318                 $string = "0s" unless ($string);
319         }
320         return $string;
321 }
322
323 sub full {
324         my $self = shift;
325         $$self{empty} = 0;
326 }
327
328 =head2 $utils_obj->set_psname('string') OR set_psname('string')
329
330 Sets the name of this process in a B<ps> listing to B<string>.
331
332
333 =cut
334
335 sub set_psname {
336         my $self = shift;
337         my $PS_NAME = shift || $self;
338         $0 = $PS_NAME if ($PS_NAME);
339 }
340
341 sub clense_ISO8601 {
342         my $self = shift;
343         my $date = shift || $self;
344         if ($date =~ /(\d{4})-?(\d{2})-?(\d{2}).?(\d{2}):(\d{2}):(\d{2})\.?\d*((?:-|\+)[0-9:]{2,5})?$/) {
345                 my $z = $7 || '+00:00';
346                 if (length($z) > 3 && $z !~ /:/o) {
347                         substr($z,3,0,':');
348                 }
349                 $date = "$1-$2-$3T$4:$5:$6$z";
350         }
351         return $date;
352 }
353
354 =head2 $utils_obj->daemonize('ps_name') OR daemonize('ps_name')
355
356 Turns the current process into a daemon.  B<ps_name> is optional, and is used
357 as the argument to I<< set_psname() >> if passed.
358
359
360 =cut
361
362 sub daemonize {
363         my $self = shift;
364         my $PS_NAME = shift || $self;
365         my $pid;
366         if ($pid = safe_fork($self)) {
367                 exit 0;
368         } elsif (defined($pid)) {
369                 set_psname($PS_NAME);
370                 chdir '/';
371                 setsid;
372                 return $$;
373         }
374 }
375
376 =head2 $utils_obj->safe_fork('ps_name') OR safe_fork('ps_name');
377
378 Forks the current process in a retry loop.  B<ps_name> is optional, and is used
379 as the argument to I<< set_psname() >> if passed.
380
381
382 =cut
383
384 sub safe_fork {
385         my $self = shift;
386         my $pid;
387
388 FORK:
389         {
390                 if (defined($pid = fork())) {
391                         srand(time ^ ($$ + ($$ << 15))) unless ($pid);
392                         return $pid;
393                 } elsif ($! == EAGAIN) {
394                         $self->error("Can't fork()!  $!, taking 5 and trying again.") if (ref $self);
395                         sleep 5;
396                         redo FORK;
397                 } else {
398                         $self->error("Can't fork()! $!") if ($! && ref($self));
399                         exit $!;
400                 }
401         }
402 }
403
404 #------------------------------------------------------------------------------------------------------------------------------------
405
406
407 1;