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