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