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;