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