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