src/perl/lib/OpenSRF/Utils.pm

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