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 ($3 eq 's');
 246                 $amount += 60 * $1 if ($3 eq 'm' || $2 =~ /^mi/io);
 247                 $amount += 60 * 60 * $1 if ($3 eq 'h');
 248                 $amount += 60 * 60 * 24 * $1 if ($3 eq 'd');
 249                 $amount += 60 * 60 * 24 * 7 * $1 if ($3 eq 'w');
 250                 $amount += ((60 * 60 * 24 * 365)/12) * $1 if ($3 eq 'M' || $2 =~ /^mo/io);
 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 =~ /^\s*(\d{4})-?(\d{2})-?(\d{2}).?(\d{2}):(\d{2}):(\d{2})\.?\d*((?:-|\+)[0-9:]{2,5})?\s*$/o) {
 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;