perl/DXUtil.pm

   1 #
   2 # various utilities which are exported globally
   3 #
   4 # Copyright (c) 1998 - Dirk Koopman G1TLH
   5 #
   6 # $Id$
   7 #
   8
   9 package DXUtil;
  10
  11 use Date::Parse;
  12
  13 require Exporter;
  14 @ISA = qw(Exporter);
  15 @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf parray parraypairs
  16              print_all_fields cltounix
  17             );
  18
  19 @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  20
  21 # a full time for logging and other purposes
  22 sub atime
  23 {
  24   my $t = shift;
  25   my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
  26   $year += 1900;
  27   my $buf = sprintf "%02d%s%04d\@%02d:%02d:%02d", $mday, $month[$mon], $year, $hour, $min, $sec;
  28   return $buf;
  29 }
  30
  31 # get a zulu time in cluster format (2300Z)
  32 sub ztime
  33 {
  34   my $t = shift;
  35   my ($sec,$min,$hour) = gmtime((defined $t) ? $t : time);
  36   $year += 1900;
  37   my $buf = sprintf "%02d%02dZ", $hour, $min;
  38   return $buf;
  39
  40 }
  41
  42 # get a cluster format date (23-Jun-1998)
  43 sub cldate
  44 {
  45   my $t = shift;
  46   my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
  47   $year += 1900;
  48   my $buf = sprintf "%02d-%s-%04d", $mday, $month[$mon], $year;
  49   return $buf;
  50 }
  51
  52 # return a cluster style date time
  53 sub cldatetime
  54 {
  55   my $t = shift;
  56   my $date = cldate($t);
  57   my $time = ztime($t);
  58   return "$date $time";
  59 }
  60
  61 # return a unix date from a cluster date and time
  62 sub cltounix
  63 {
  64   my $date = shift;
  65   my $time = shift;
  66   $date =~ s/^\s*(\d+)-(\w\w\w)-(19\d\d)$/$1 $2 $3/;
  67   $time =~ s/^(\d\d)(\d\d)Z$/$1:$2 +0000/;
  68   return str2time("$date $time");
  69 }
  70
  71 # turn a latitude in degrees into a string
  72 sub slat
  73 {
  74   my $n = shift;
  75   my ($deg, $min, $let);
  76   $let = $n >= 0 ? 'N' : 'S';
  77   $n = abs $n;
  78   $deg = int $n;
  79   $min = int (($n - $deg) * 60);
  80   return "$deg $min $let";
  81 }
  82
  83 # turn a longitude in degrees into a string
  84 sub slong
  85 {
  86   my $n = shift;
  87   my ($deg, $min, $let);
  88   $let = $n >= 0 ? 'E' : 'W';
  89   $n = abs $n;
  90   $deg = int $n;
  91   $min = int (($n - $deg) * 60);
  92   return "$deg $min $let";
  93 }
  94
  95 # turn a true into 'yes' and false into 'no'
  96 sub yesno
  97 {
  98   my $n = shift;
  99   return $n ? $main::yes : $main::no;
 100 }
 101
 102 # format a prompt with its current value and return it with its privilege
 103 sub promptf
 104 {
 105   my ($line, $value) = @_;
 106   my ($priv, $prompt, $action) = split ',', $line;
 107
 108   # if there is an action treat it as a subroutine and replace $value
 109   if ($action) {
 110     my $q = qq{\$value = $action(\$value)};
 111         eval $q;
 112   }
 113   $prompt = sprintf "%15s: %s", $prompt, $value;
 114   return ($priv, $prompt);
 115 }
 116
 117 # take an arg as an array list and print it
 118 sub parray
 119 {
 120   return join(', ', @{shift});
 121 }
 122
 123 # take the arg as an array reference and print as a list of pairs
 124 sub parraypairs
 125 {
 126   my $ref = shift;
 127   my $i;
 128   my $out;
 129
 130   for ($i = 0; $i < @$ref; $i += 2) {
 131     my $r1 = @$ref[$i];
 132         my $r2 = @$ref[$i+1];
 133         $out .= "$r1-$r2, ";
 134   }
 135   chop $out;     # remove last space
 136   chop $out;     # remove last comma
 137   return $out;
 138 }
 139
 140 # print all the fields for a record according to privilege
 141 #
 142 # The prompt record is of the format '<priv>,<prompt>[,<action>'
 143 # and is expanded by promptf above
 144 #
 145 sub print_all_fields
 146 {
 147   my $self = shift;    # is a dxchan
 148   my $ref = shift;     # is a thingy with field_prompt and fields methods defined
 149   my @out = @_;
 150
 151   my @fields = $ref->fields;
 152   my $field;
 153   my @out;
 154
 155   foreach $field (sort @fields) {
 156     my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field});
 157     push @out, $ans if ($self->priv >= $priv);
 158   }
 159   return @out;
 160 }
 161