perl/DXUtil.pm

   1 #
   2 # various utilities which are exported globally
   3 #
   4 # Copyright (c) 1998 - Dirk Koopman G1TLH
   5 #
   6 #
   7 #
   8
   9 package DXUtil;
  10
  11 use Date::Parse;
  12 use IO::File;
  13 use File::Copy;
  14 use Data::Dumper;
  15
  16 use strict;
  17
  18 use vars qw(@month %patmap $pi $d2r $r2d @ISA @EXPORT);
  19
  20 require Exporter;
  21 @ISA = qw(Exporter);
  22 @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf
  23                          parray parraypairs phex phash shellregex readfilestr writefilestr
  24                          filecopy ptimelist
  25              print_all_fields cltounix unpad is_callsign is_long_callsign is_latlong
  26                          is_qra is_freq is_digits is_pctext is_pcflag insertitem deleteitem
  27                          is_prefix dd is_ipaddr $pi $d2r $r2d
  28             );
  29
  30
  31 @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  32 %patmap = (
  33                    '*' => '.*',
  34                    '?' => '.',
  35                    '[' => '[',
  36                    ']' => ']'
  37 );
  38
  39 $pi = 3.141592653589;
  40 $d2r = ($pi/180);
  41 $r2d = (180/$pi);
  42
  43
  44 # a full time for logging and other purposes
  45 sub atime
  46 {
  47         my $t = shift;
  48         my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
  49         $year += 1900;
  50         my $buf = sprintf "%02d%s%04d\@%02d:%02d:%02d", $mday, $month[$mon], $year, $hour, $min, $sec;
  51         return $buf;
  52 }
  53
  54 # get a zulu time in cluster format (2300Z)
  55 sub ztime
  56 {
  57         my $t = shift;
  58         $t = defined $t ? $t : time;
  59         my $dst = shift;
  60         my ($sec,$min,$hour) = $dst ? localtime($t): gmtime($t);
  61         my $buf = sprintf "%02d%02d%s", $hour, $min, ($dst) ? '' : 'Z';
  62         return $buf;
  63 }
  64
  65 # get a cluster format date (23-Jun-1998)
  66 sub cldate
  67 {
  68         my $t = shift;
  69         $t = defined $t ? $t : time;
  70         my $dst = shift;
  71         my ($sec,$min,$hour,$mday,$mon,$year) = $dst ? localtime($t) : gmtime($t);
  72         $year += 1900;
  73         my $buf = sprintf "%2d-%s-%04d", $mday, $month[$mon], $year;
  74         return $buf;
  75 }
  76
  77 # return a cluster style date time
  78 sub cldatetime
  79 {
  80         my $t = shift;
  81         my $dst = shift;
  82         my $date = cldate($t, $dst);
  83         my $time = ztime($t, $dst);
  84         return "$date $time";
  85 }
  86
  87 # return a unix date from a cluster date and time
  88 sub cltounix
  89 {
  90         my $date = shift;
  91         my $time = shift;
  92         my ($thisyear) = (gmtime)[5] + 1900;
  93
  94         return 0 unless $date =~ /^\s*(\d+)-(\w\w\w)-([12][90]\d\d)$/;
  95         return 0 if $3 > 2036;
  96         return 0 unless abs($thisyear-$3) <= 1;
  97         $date = "$1 $2 $3";
  98         return 0 unless $time =~ /^([012]\d)([012345]\d)Z$/;
  99         $time = "$1:$2 +0000";
 100         my $r = str2time("$date $time");
 101         return $r unless $r;
 102         return $r == -1 ? undef : $r;
 103 }
 104
 105 # turn a latitude in degrees into a string
 106 sub slat
 107 {
 108         my $n = shift;
 109         my ($deg, $min, $let);
 110         $let = $n >= 0 ? 'N' : 'S';
 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 longitude in degrees into a string
 118 sub slong
 119 {
 120         my $n = shift;
 121         my ($deg, $min, $let);
 122         $let = $n >= 0 ? 'E' : 'W';
 123         $n = abs $n;
 124         $deg = int $n;
 125         $min = int ((($n - $deg) * 60) + 0.5);
 126         return "$deg $min $let";
 127 }
 128
 129 # turn a true into 'yes' and false into 'no'
 130 sub yesno
 131 {
 132         my $n = shift;
 133         return $n ? $main::yes : $main::no;
 134 }
 135
 136 # provide a data dumpered version of the object passed
 137 sub dd
 138 {
 139         my $value = shift;
 140         my $dd = new Data::Dumper([$value]);
 141         $dd->Indent(0);
 142         $dd->Terse(1);
 143     $dd->Quotekeys($] < 5.005 ? 1 : 0);
 144         $value = $dd->Dumpxs;
 145         $value =~ s/([\r\n\t])/sprintf("%%%02X", ord($1))/eg;
 146         $value =~ s/^\s*\[//;
 147     $value =~ s/\]\s*$//;
 148
 149         return $value;
 150 }
 151
 152 # format a prompt with its current value and return it with its privilege
 153 sub promptf
 154 {
 155         my ($line, $value) = @_;
 156         my ($priv, $prompt, $action) = split ',', $line;
 157
 158         # if there is an action treat it as a subroutine and replace $value
 159         if ($action) {
 160                 my $q = qq{\$value = $action(\$value)};
 161                 eval $q;
 162         } elsif (ref $value) {
 163                 $value = dd($value);
 164         }
 165         $prompt = sprintf "%15s: %s", $prompt, $value;
 166         return ($priv, $prompt);
 167 }
 168
 169 # turn a hex field into printed hex
 170 sub phex
 171 {
 172         my $val = shift;
 173         return sprintf '%X', $val;
 174 }
 175
 176 # take an arg as a hash of call=>time pairs and print it
 177 sub ptimelist
 178 {
 179         my $ref = shift;
 180         my $out;
 181         for (sort keys %$ref) {
 182                 $out .= "$_=$ref->{$_}, ";
 183         }
 184         chop $out;
 185         chop $out;
 186         return $out;
 187 }
 188
 189 # take an arg as an array list and print it
 190 sub parray
 191 {
 192         my $ref = shift;
 193         return ref $ref ? join(', ', @{$ref}) : $ref;
 194 }
 195
 196 # take the arg as an array reference and print as a list of pairs
 197 sub parraypairs
 198 {
 199         my $ref = shift;
 200         my $i;
 201         my $out;
 202
 203         for ($i = 0; $i < @$ref; $i += 2) {
 204                 my $r1 = @$ref[$i];
 205                 my $r2 = @$ref[$i+1];
 206                 $out .= "$r1-$r2, ";
 207         }
 208         chop $out;                                      # remove last space
 209         chop $out;                                      # remove last comma
 210         return $out;
 211 }
 212
 213 # take the arg as a hash reference and print it out as such
 214 sub phash
 215 {
 216         my $ref = shift;
 217         my $out;
 218
 219         while (my ($k,$v) = each %$ref) {
 220                 $out .= "${k}=>$v, ";
 221         }
 222         chop $out;                                      # remove last space
 223         chop $out;                                      # remove last comma
 224         return $out;
 225 }
 226
 227 sub _sort_fields
 228 {
 229         my $ref = shift;
 230         my @a = split /,/, $ref->field_prompt(shift);
 231         my @b = split /,/, $ref->field_prompt(shift);
 232         return lc $a[1] cmp lc $b[1];
 233 }
 234
 235 # print all the fields for a record according to privilege
 236 #
 237 # The prompt record is of the format '<priv>,<prompt>[,<action>'
 238 # and is expanded by promptf above
 239 #
 240 sub print_all_fields
 241 {
 242         my $self = shift;                       # is a dxchan
 243         my $ref = shift;                        # is a thingy with field_prompt and fields methods defined
 244         my @out;
 245         my @fields = $ref->fields;
 246         my $field;
 247         my $width = $self->width - 1;
 248         $width ||= 80;
 249
 250         foreach $field (sort {_sort_fields($ref, $a, $b)} @fields) {
 251                 if (defined $ref->{$field}) {
 252                         my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field});
 253                         my @tmp;
 254                         if (length $ans > $width) {
 255                                 my ($p, $a) = split /: /, $ans, 2;
 256                                 my $l = (length $p) + 2;
 257                                 my $al = ($width - 1) - $l;
 258                                 my $bit;
 259                                 while (length $a > $al ) {
 260                                         ($bit, $a) = unpack "A$al A*", $a;
 261                                         push @tmp, "$p: $bit";
 262                                         $p = ' ' x ($l - 2);
 263                                 }
 264                                 push @tmp, "$p: $a" if length $a;
 265                         } else {
 266                                 push @tmp, $ans;
 267                         }
 268                         push @out, @tmp if ($self->priv >= $priv);
 269                 }
 270         }
 271         return @out;
 272 }
 273
 274 # generate a regex from a shell type expression
 275 # see 'perl cookbook' 6.9
 276 sub shellregex
 277 {
 278         my $in = shift;
 279         $in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
 280         return '^' . $in . "\$";
 281 }
 282
 283 # read in a file into a string and return it.
 284 # the filename can be split into a dir and file and the
 285 # file can be in upper or lower case.
 286 # there can also be a suffix
 287 sub readfilestr
 288 {
 289         my ($dir, $file, $suffix) = @_;
 290         my $fn;
 291         my $f;
 292         if ($suffix) {
 293                 $f = uc $file;
 294                 $fn = "$dir/$f.$suffix";
 295                 unless (-e $fn) {
 296                         $f = lc $file;
 297                         $fn = "$dir/$file.$suffix";
 298                 }
 299         } elsif ($file) {
 300                 $f = uc $file;
 301                 $fn = "$dir/$file";
 302                 unless (-e $fn) {
 303                         $f = lc $file;
 304                         $fn = "$dir/$file";
 305                 }
 306         } else {
 307                 $fn = $dir;
 308         }
 309
 310         my $fh = new IO::File $fn;
 311         my $s = undef;
 312         if ($fh) {
 313                 local $/ = undef;
 314                 $s = <$fh>;
 315                 $fh->close;
 316         }
 317         return $s;
 318 }
 319
 320 # write out a file in the format required for reading
 321 # in via readfilestr, it expects the same arguments
 322 # and a reference to an object
 323 sub writefilestr
 324 {
 325         my $dir = shift;
 326         my $file = shift;
 327         my $suffix = shift;
 328         my $obj = shift;
 329         my $fn;
 330         my $f;
 331
 332         confess('no object to write in writefilestr') unless $obj;
 333         confess('object not a reference in writefilestr') unless ref $obj;
 334
 335         if ($suffix) {
 336                 $f = uc $file;
 337                 $fn = "$dir/$f.$suffix";
 338                 unless (-e $fn) {
 339                         $f = lc $file;
 340                         $fn = "$dir/$file.$suffix";
 341                 }
 342         } elsif ($file) {
 343                 $f = uc $file;
 344                 $fn = "$dir/$file";
 345                 unless (-e $fn) {
 346                         $f = lc $file;
 347                         $fn = "$dir/$file";
 348                 }
 349         } else {
 350                 $fn = $dir;
 351         }
 352
 353         my $fh = new IO::File ">$fn";
 354         if ($fh) {
 355                 my $dd = new Data::Dumper([ $obj ]);
 356                 $dd->Indent(1);
 357                 $dd->Terse(1);
 358                 $dd->Quotekeys(0);
 359                 #       $fh->print(@_) if @_ > 0;     # any header comments, lines etc
 360                 $fh->print($dd->Dumpxs);
 361                 $fh->close;
 362         }
 363 }
 364
 365 sub filecopy
 366 {
 367         copy(@_) or return $!;
 368 }
 369
 370 # remove leading and trailing spaces from an input string
 371 sub unpad
 372 {
 373         my $s = shift;
 374         $s =~ s/\s+$//;
 375         $s =~ s/^\s+//;
 376         return $s;
 377 }
 378
 379 # check that a field only has callsign characters in it
 380 sub is_callsign
 381 {
 382         return $_[0] =~ m!^(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+)        # basic prefix
 383                        (?:/(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+))?  # / another one (possibly)
 384                                            [A-Z]{1,4}                                 # callsign letters
 385                                            (?:/(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+))?  # / another prefix possibly
 386                        (?:/[0-9A-Z]{1,2})?                        # /0-9A-Z+ possibly
 387                                            (?:-\d{1,2})?                              # - nn possibly
 388                                          $!x;
 389 }
 390
 391 # check that a field only has callsign characters in it but has more than the standard 3 callsign letters
 392 sub is_long_callsign
 393 {
 394         return $_[0] =~ m!^(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+)        # basic prefix
 395                        (?:/(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+))?  # / another one (possibly)
 396                                            [A-Z]{1,5}                                 # callsign letters
 397                                            (?:/(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+))?  # / another prefix possibly
 398                        (?:/[0-9A-Z]{1,2})?                        # /0-9A-Z+ possibly
 399                                            (?:-\d{1,2})?                              # - nn possibly
 400                                          $!x;
 401 }
 402
 403 sub is_prefix
 404 {
 405         return $_[0] =~ m!^(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+)!x        # basic prefix
 406 }
 407
 408
 409 # check that a PC protocol field is valid text
 410 sub is_pctext
 411 {
 412         return undef unless length $_[0];
 413         return undef if $_[0] =~ /[\x00-\x08\x0a-\x1f\x80-\x9f]/;
 414         return 1;
 415 }
 416
 417 # check that a PC prot flag is fairly valid (doesn't check the difference between 1/0 and */-)
 418 sub is_pcflag
 419 {
 420         return $_[0] =~ /^[01\*\-]+$/;
 421 }
 422
 423 # check that a thing is a frequency
 424 sub is_freq
 425 {
 426         return $_[0] =~ /^\d+(?:\.\d+)?$/;
 427 }
 428
 429 # check that a thing is just digits
 430 sub is_digits
 431 {
 432         return $_[0] =~ /^[\d]+$/;
 433 }
 434
 435 # does it look like a qra locator?
 436 sub is_qra
 437 {
 438         return $_[0] =~ /^[A-Ra-r][A-Ra-r]\d\d[A-Xa-x][A-Xa-x]$/;
 439 }
 440
 441 # does it look like a valid lat/long
 442 sub is_latlong
 443 {
 444         return $_[0] =~ /^\s*\d{1,2}\s+\d{1,2}\s*[NnSs]\s+1?\d{1,2}\s+\d{1,2}\s*[EeWw]\s*$/;
 445 }
 446
 447 # is it an ip address?
 448 sub is_ipaddr
 449 {
 450     return $_[0] =~ /^\d+\.\d+\.\d+\.\d+$/ || $_[0] =~ /^[0-9a-f:]+$/;
 451 }
 452
 453 # insert an item into a list if it isn't already there returns 1 if there 0 if not
 454 sub insertitem
 455 {
 456         my $list = shift;
 457         my $item = shift;
 458
 459         return 1 if grep {$_ eq $item } @$list;
 460         push @$list, $item;
 461         return 0;
 462 }
 463
 464 # delete an item from a list if it is there returns no deleted
 465 sub deleteitem
 466 {
 467         my $list = shift;
 468         my $item = shift;
 469         my $n = @$list;
 470
 471         @$list = grep {$_ ne $item } @$list;
 472         return $n - @$list;
 473 }
 474