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