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 IO::File;
  13 use Data::Dumper;
  14
  15 use Carp;
  16
  17 require Exporter;
  18 @ISA = qw(Exporter);
  19 @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf
  20                          parray parraypairs shellregex readfilestr writefilestr
  21              print_all_fields cltounix iscallsign
  22             );
  23
  24 @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  25 %patmap = (
  26                    '*' => '.*',
  27                    '?' => '.',
  28                    '[' => '[',
  29                    ']' => ']'
  30 );
  31
  32 # a full time for logging and other purposes
  33 sub atime
  34 {
  35         my $t = shift;
  36         my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
  37         $year += 1900;
  38         my $buf = sprintf "%02d%s%04d\@%02d:%02d:%02d", $mday, $month[$mon], $year, $hour, $min, $sec;
  39         return $buf;
  40 }
  41
  42 # get a zulu time in cluster format (2300Z)
  43 sub ztime
  44 {
  45         my $t = shift;
  46         $t = defined $t ? $t : time;
  47         my $dst = shift;
  48         my ($sec,$min,$hour) = $dst ? localtime($t): gmtime($t);
  49         my $buf = sprintf "%02d%02d%s", $hour, $min, ($dst) ? '' : 'Z';
  50         return $buf;
  51 }
  52
  53 # get a cluster format date (23-Jun-1998)
  54 sub cldate
  55 {
  56         my $t = shift;
  57         $t = defined $t ? $t : time;
  58         my $dst = shift;
  59         my ($sec,$min,$hour,$mday,$mon,$year) = $dst ? localtime($t) : gmtime($t);
  60         $year += 1900;
  61         my $buf = sprintf "%2d-%s-%04d", $mday, $month[$mon], $year;
  62         return $buf;
  63 }
  64
  65 # return a cluster style date time
  66 sub cldatetime
  67 {
  68         my $t = shift;
  69         my $dst = shift;
  70         my $date = cldate($t, $dst);
  71         my $time = ztime($t, $dst);
  72         return "$date $time";
  73 }
  74
  75 # return a unix date from a cluster date and time
  76 sub cltounix
  77 {
  78         my $date = shift;
  79         my $time = shift;
  80         my ($thisyear) = (gmtime)[5] + 1900;
  81
  82         return 0 unless $date =~ /^\s*(\d+)-(\w\w\w)-([12][90]\d\d)$/;
  83         return 0 if $3 > 2036;
  84         return 0 unless abs($thisyear-$3) <= 1;
  85         $date = "$1 $2 $3";
  86         return 0 unless $time =~ /^([012]\d)([012345]\d)Z$/;
  87         $time = "$1:$2 +0000";
  88         my $r = str2time("$date $time");
  89         return $r unless $r;
  90         return $r == -1 ? undef : $r;
  91 }
  92
  93 # turn a latitude in degrees into a string
  94 sub slat
  95 {
  96         my $n = shift;
  97         my ($deg, $min, $let);
  98         $let = $n >= 0 ? 'N' : 'S';
  99         $n = abs $n;
 100         $deg = int $n;
 101         $min = int ((($n - $deg) * 60) + 0.5);
 102         return "$deg $min $let";
 103 }
 104
 105 # turn a longitude in degrees into a string
 106 sub slong
 107 {
 108         my $n = shift;
 109         my ($deg, $min, $let);
 110         $let = $n >= 0 ? 'E' : 'W';
 111         $n = abs $n;
 112         $deg = int $n;
 113         $min = int ((($n - $deg) * 60) + 0.5);
 114         return "$deg $min $let";
 115 }
 116
 117 # turn a true into 'yes' and false into 'no'
 118 sub yesno
 119 {
 120         my $n = shift;
 121         return $n ? $main::yes : $main::no;
 122 }
 123
 124 # format a prompt with its current value and return it with its privilege
 125 sub promptf
 126 {
 127         my ($line, $value) = @_;
 128         my ($priv, $prompt, $action) = split ',', $line;
 129
 130         # if there is an action treat it as a subroutine and replace $value
 131         if ($action) {
 132                 my $q = qq{\$value = $action(\$value)};
 133                 eval $q;
 134         }
 135         $prompt = sprintf "%15s: %s", $prompt, $value;
 136         return ($priv, $prompt);
 137 }
 138
 139 # take an arg as an array list and print it
 140 sub parray
 141 {
 142         my $ref = shift;
 143         return join(', ', @{$ref});
 144 }
 145
 146 # take the arg as an array reference and print as a list of pairs
 147 sub parraypairs
 148 {
 149         my $ref = shift;
 150         my $i;
 151         my $out;
 152
 153         for ($i = 0; $i < @$ref; $i += 2) {
 154                 my $r1 = @$ref[$i];
 155                 my $r2 = @$ref[$i+1];
 156                 $out .= "$r1-$r2, ";
 157         }
 158         chop $out;                                      # remove last space
 159         chop $out;                                      # remove last comma
 160         return $out;
 161 }
 162
 163 # print all the fields for a record according to privilege
 164 #
 165 # The prompt record is of the format '<priv>,<prompt>[,<action>'
 166 # and is expanded by promptf above
 167 #
 168 sub print_all_fields
 169 {
 170         my $self = shift;                       # is a dxchan
 171         my $ref = shift;                        # is a thingy with field_prompt and fields methods defined
 172         my @out;
 173         my @fields = $ref->fields;
 174         my $field;
 175
 176         foreach $field (sort {$ref->field_prompt($a) cmp $ref->field_prompt($b)} @fields) {
 177                 if (defined $ref->{$field}) {
 178                         my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field});
 179                         push @out, $ans if ($self->priv >= $priv);
 180                 }
 181         }
 182         return @out;
 183 }
 184
 185 # generate a regex from a shell type expression
 186 # see 'perl cookbook' 6.9
 187 sub shellregex
 188 {
 189         my $in = shift;
 190         $in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
 191         return '^' . $in . "\$";
 192 }
 193
 194 # start an attempt at determining whether this string might be a callsign
 195 sub iscallsign
 196 {
 197         my $call = uc shift;
 198         return 1 if $call =~ /^[A-Z]+\d+[A-Z]+/;
 199         return 1 if $call =~ /^\d+[A-Z]\d+[A-Z]+/;
 200         return undef;
 201 }
 202
 203 # read in a file into a string and return it.
 204 # the filename can be split into a dir and file and the
 205 # file can be in upper or lower case.
 206 # there can also be a suffix
 207 sub readfilestr
 208 {
 209         my ($dir, $file, $suffix) = @_;
 210         my $fn;
 211         my $f;
 212         if ($suffix) {
 213                 $f = uc $file;
 214                 $fn = "$dir/$f.$suffix";
 215                 unless (-e $fn) {
 216                         $f = lc $file;
 217                         $fn = "$dir/$file.$suffix";
 218                 }
 219         } elsif ($file) {
 220                 $f = uc $file;
 221                 $fn = "$dir/$file";
 222                 unless (-e $fn) {
 223                         $f = lc $file;
 224                         $fn = "$dir/$file";
 225                 }
 226         } else {
 227                 $fn = $dir;
 228         }
 229
 230         my $fh = new IO::File $fn;
 231         my $s = undef;
 232         if ($fh) {
 233                 local $/ = undef;
 234                 $s = <$fh>;
 235                 $fh->close;
 236         }
 237         return $s;
 238 }
 239
 240 # write out a file in the format required for reading
 241 # in via readfilestr, it expects the same arguments
 242 # and a reference to an object
 243 sub writefilestr
 244 {
 245         my $dir = shift;
 246         my $file = shift;
 247         my $suffix = shift;
 248         my $obj = shift;
 249         my $fn;
 250         my $f;
 251
 252         confess('no object to write in writefilestr') unless $obj;
 253         confess('object not a reference in writefilestr') unless ref $obj;
 254
 255         if ($suffix) {
 256                 $f = uc $file;
 257                 $fn = "$dir/$f.$suffix";
 258                 unless (-e $fn) {
 259                         $f = lc $file;
 260                         $fn = "$dir/$file.$suffix";
 261                 }
 262         } elsif ($file) {
 263                 $f = uc $file;
 264                 $fn = "$dir/$file";
 265                 unless (-e $fn) {
 266                         $f = lc $file;
 267                         $fn = "$dir/$file";
 268                 }
 269         } else {
 270                 $fn = $dir;
 271         }
 272
 273         my $fh = new IO::File ">$fn";
 274         if ($fh) {
 275                 my $dd = new Data::Dumper([ $obj ]);
 276                 $dd->Indent(1);
 277                 $dd->Terse(1);
 278                 $dd->Quotekeys(0);
 279                 #       $fh->print(@_) if @_ > 0;     # any header comments, lines etc
 280                 $fh->print($dd->Dumpxs);
 281                 $fh->close;
 282         }
 283 }