X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUtil.pm;h=157ff609534515009faf6ff07914e690784fd349;hb=refs%2Fheads%2Fnewdisc;hp=db1c4c7da9c952c2a8b6482dfc0c1a41669b8ea5;hpb=0ee845aaebeeb0f5a7232021d9c633a0ef2fff80;p=spider.git diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index db1c4c7d..157ff609 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -3,23 +3,34 @@ # # Copyright (c) 1998 - Dirk Koopman G1TLH # -# $Id$ +# # package DXUtil; + use Date::Parse; use IO::File; +use File::Copy; use Data::Dumper; +use Time::HiRes qw(gettimeofday tv_interval); + +use strict; + +use vars qw(@month %patmap $pi $d2r $r2d @ISA @EXPORT); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf - parray parraypairs shellregex readfilestr writefilestr - print_all_fields cltounix iscallsign unpad is_callsign - is_freq is_digits is_pctext is_pcflag insertitem deleteitem + parray parraypairs phex phash shellregex readfilestr writefilestr + filecopy ptimelist + print_all_fields cltounix unpad is_callsign is_latlong + is_qra is_freq is_digits is_pctext is_pcflag insertitem deleteitem + is_prefix dd is_ipaddr $pi $d2r $r2d localdata localdata_mv + diffms ); + @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); %patmap = ( '*' => '.*', @@ -28,6 +39,11 @@ require Exporter; ']' => ']' ); +$pi = 3.141592653589; +$d2r = ($pi/180); +$r2d = (180/$pi); + + # a full time for logging and other purposes sub atime { @@ -120,6 +136,22 @@ sub yesno return $n ? $main::yes : $main::no; } +# provide a data dumpered version of the object passed +sub dd +{ + my $value = shift; + my $dd = new Data::Dumper([$value]); + $dd->Indent(0); + $dd->Terse(1); + $dd->Quotekeys($] < 5.005 ? 1 : 0); + $value = $dd->Dumpxs; + $value =~ s/([\r\n\t])/sprintf("%%%02X", ord($1))/eg; + $value =~ s/^\s*\[//; + $value =~ s/\]\s*$//; + + return $value; +} + # format a prompt with its current value and return it with its privilege sub promptf { @@ -131,21 +163,37 @@ sub promptf my $q = qq{\$value = $action(\$value)}; eval $q; } elsif (ref $value) { - my $dd = new Data::Dumper([$value]); - $dd->Indent(0); - $dd->Terse(1); - $dd->Quotekeys(0); - $value = $dd->Dumpxs; + $value = dd($value); } $prompt = sprintf "%15s: %s", $prompt, $value; return ($priv, $prompt); } +# turn a hex field into printed hex +sub phex +{ + my $val = shift; + return sprintf '%X', $val; +} + +# take an arg as a hash of call=>time pairs and print it +sub ptimelist +{ + my $ref = shift; + my $out; + for (sort keys %$ref) { + $out .= "$_=$ref->{$_}, "; + } + chop $out; + chop $out; + return $out; +} + # take an arg as an array list and print it sub parray { my $ref = shift; - return join(', ', @{$ref}); + return ref $ref ? join(', ', @{$ref}) : $ref; } # take the arg as an array reference and print as a list of pairs @@ -154,7 +202,7 @@ sub parraypairs my $ref = shift; my $i; my $out; - + for ($i = 0; $i < @$ref; $i += 2) { my $r1 = @$ref[$i]; my $r2 = @$ref[$i+1]; @@ -165,6 +213,28 @@ sub parraypairs return $out; } +# take the arg as a hash reference and print it out as such +sub phash +{ + my $ref = shift; + my $out; + + while (my ($k,$v) = each %$ref) { + $out .= "${k}=>$v, "; + } + chop $out; # remove last space + chop $out; # remove last comma + return $out; +} + +sub _sort_fields +{ + my $ref = shift; + my @a = split /,/, $ref->field_prompt(shift); + my @b = split /,/, $ref->field_prompt(shift); + return lc $a[1] cmp lc $b[1]; +} + # print all the fields for a record according to privilege # # The prompt record is of the format ',[,' @@ -177,18 +247,21 @@ sub print_all_fields my @out; my @fields = $ref->fields; my $field; + my $width = $self->width - 1; + $width ||= 80; - foreach $field (sort {$ref->field_prompt($a) cmp $ref->field_prompt($b)} @fields) { + foreach $field (sort {_sort_fields($ref, $a, $b)} @fields) { if (defined $ref->{$field}) { my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field}); my @tmp; - if (length $ans > 79) { - my ($p, $a) = split /: /, $ans; + if (length $ans > $width) { + my ($p, $a) = split /: /, $ans, 2; my $l = (length $p) + 2; - my $al = 79 - $l; + my $al = ($width - 1) - $l; + my $bit; while (length $a > $al ) { - $a =~ s/^(.{$al})//; - push @tmp, "$p: $1"; + ($bit, $a) = unpack "A$al A*", $a; + push @tmp, "$p: $bit"; $p = ' ' x ($l - 2); } push @tmp, "$p: $a" if length $a; @@ -210,15 +283,6 @@ sub shellregex return '^' . $in . "\$"; } -# start an attempt at determining whether this string might be a callsign -sub iscallsign -{ - my $call = uc shift; - return 1 if $call =~ /^[A-Z]+\d+[A-Z]+/; - return 1 if $call =~ /^\d+[A-Z]\d+[A-Z]+/; - return undef; -} - # read in a file into a string and return it. # the filename can be split into a dir and file and the # file can be in upper or lower case. @@ -301,6 +365,11 @@ sub writefilestr } } +sub filecopy +{ + copy(@_) or return $!; +} + # remove leading and trailing spaces from an input string sub unpad { @@ -313,13 +382,29 @@ sub unpad # check that a field only has callsign characters in it sub is_callsign { - return $_[0] =~ /^(?:[A-Z]{1,2}\d+|\d[A-Z]\d+)[A-Z0-9\/\-]+$/; + return $_[0] =~ m!^ + (?:\d?[A-Z]{1,2}\d*/)? # out of area prefix / + (?:\d?[A-Z]{1,2}\d+) # main prefix one (required) + [A-Z]{1,5} # callsign letters (required) + (?:-(?:\d{1,2}|\#))? # - nn possibly (eg G8BPQ-8) or -# (an RBN spot) + (?:/[0-9A-Z]{1,7})? # / another prefix, callsign or special label (including /MM, /P as well as /EURO or /LGT) possibly + $!x; + + # longest callign allowed is 1X11/1Y11XXXXX-11/XXXXXXX +} + +sub is_prefix +{ + return $_[0] =~ m!^(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}}\d+)!x # basic prefix } + # check that a PC protocol field is valid text sub is_pctext { - return $_[0] =~ /^[\x09\x20-\xFF]+$/; + return undef unless length $_[0]; + return undef if $_[0] =~ /[\x00-\x08\x0a-\x1f\x80-\x9f]/; + return 1; } # check that a PC prot flag is fairly valid (doesn't check the difference between 1/0 and */-) @@ -331,7 +416,7 @@ sub is_pcflag # check that a thing is a frequency sub is_freq { - return $_[0] =~ /^[\d\.]+$/; + return $_[0] =~ /^\d+(?:\.\d+)?$/; } # check that a thing is just digits @@ -340,6 +425,25 @@ sub is_digits return $_[0] =~ /^[\d]+$/; } +# does it look like a qra locator? +sub is_qra +{ + return unless length $_[0] == 4 || length $_[0] == 6; + return $_[0] =~ /^[A-Ra-r][A-Ra-r]\d\d(?:[A-Xa-x][A-Xa-x])?$/; +} + +# does it look like a valid lat/long +sub is_latlong +{ + return $_[0] =~ /^\s*\d{1,2}\s+\d{1,2}\s*[NnSs]\s+1?\d{1,2}\s+\d{1,2}\s*[EeWw]\s*$/; +} + +# is it an ip address? +sub is_ipaddr +{ + return $_[0] =~ /^\d+\.\d+\.\d+\.\d+$/ || $_[0] =~ /^[0-9a-f:,]+$/; +} + # insert an item into a list if it isn't already there returns 1 if there 0 if not sub insertitem { @@ -361,3 +465,54 @@ sub deleteitem @$list = grep {$_ ne $item } @$list; return $n - @$list; } + +# find the correct local_data directory +# basically, if there is a local_data directory with this filename and it is younger than the +# equivalent one in the (system) data directory then return that name rather than the system one +sub localdata +{ + my $ifn = shift; + my $ofn = "$main::data/$ifn"; + my $tfn; + + if (-e "$main::local_data") { + $tfn = "$main::local_data/$ifn"; + if (-e $tfn && -e $ofn) { + $ofn = $tfn if -M $tfn < -M $ofn; + } elsif (-e $tfn) { + $ofn = $tfn; + } + } + + return $ofn; +} + +# move a file or a directory from data -> local_data if isn't there already +sub localdata_mv +{ + my $ifn = shift; + if (-e "$main::data/$ifn" ) { + unless (-e "$main::local_data/$ifn") { + move("$main::data/$ifn", "$main::local_data/$ifn") or die "localdata_mv: cannot move $ifn from '$main::data' -> '$main::local_data' $!\n"; + } + } +} + +# measure the time taken for something to happen; use Time::HiRes qw(gettimeofday tv_interval); +sub diffms +{ + my $call = shift; + my $line = shift; + my $ta = shift; + my $no = shift; + my $tb = shift || [gettimeofday]; + + my $a = int($ta->[0] * 1000) + int($ta->[1] / 1000); + my $b = int($tb->[0] * 1000) + int($tb->[1] / 1000); + my $msecs = $b - $a; + + $line =~ s|\s+$||; + my $s = "subprocess stats cmd: '$line' $call ${msecs}mS"; + $s .= " $no lines" if $no; + DXDebug::dbg($s); +}