X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUtil.pm;h=51272d743420eea029be9a8d0b9e04bc77e029a1;hb=710e02b70cb2530802812577229cd62a50da8090;hp=e93d7ab4e6d87bd37e1d07c88f4e0fd748dc8c64;hpb=2520521008cdb3c5ab168c678c57130be712daee;p=spider.git diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index e93d7ab4..51272d74 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -14,6 +14,7 @@ use IO::File; use File::Copy; use Data::Dumper; use Time::HiRes qw(gettimeofday tv_interval); +use Text::Wrap; use strict; @@ -27,7 +28,8 @@ require Exporter; 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 _diffms difft parraydifft is_ztime + diffms _diffms _diffus difft parraydifft is_ztime basecall + normalise_call ); @@ -155,7 +157,7 @@ sub dd # format a prompt with its current value and return it with its privilege sub promptf { - my ($line, $value) = @_; + my ($line, $value, $promptl) = @_; my ($priv, $prompt, $action) = split ',', $line; # if there is an action treat it as a subroutine and replace $value @@ -165,7 +167,8 @@ sub promptf } elsif (ref $value) { $value = dd($value); } - $prompt = sprintf "%15s: %s", $prompt, $value; + $promptl ||= 15; + $prompt = sprintf "%${promptl}s: %s", $prompt, $value; return ($priv, $prompt); } @@ -193,7 +196,7 @@ sub ptimelist sub parray { my $ref = shift; - return ref $ref ? join(', ', @{$ref}) : $ref; + return ref $ref ? join(', ', sort @{$ref}) : $ref; } # take the arg as an array reference and print as a list of pairs @@ -219,11 +222,10 @@ sub phash my $ref = shift; my $out; - while (my ($k,$v) = each %$ref) { - $out .= "${k}=>$v, "; + while (my $k = sort keys %$ref) { + $out .= "${k}=>$ref->{$k}, "; } - chop $out; # remove last space - chop $out; # remove last comma + $out =~ s/, $// if $out; return $out; } @@ -248,23 +250,26 @@ sub print_all_fields my @fields = $ref->fields; my $field; my $width = $self->width - 1; + my $promptl = 0; $width ||= 80; + # find the maximum length of the prompt + foreach $field (@fields) { + if (defined $ref->{$field}) { + my (undef, $prompt, undef) = split ',', $ref->field_prompt($field); + $promptl = length $prompt if length $prompt > $promptl; + } + } + + # now do print foreach $field (sort {_sort_fields($ref, $a, $b)} @fields) { if (defined $ref->{$field}) { - my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field}); + my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field}, $promptl); my @tmp; if (length $ans > $width) { + $Text::Wrap::columns = $width-2; my ($p, $a) = split /: /, $ans, 2; - my $l = (length $p) + 2; - my $al = ($width - 1) - $l; - my $bit; - while (length $a > $al ) { - ($bit, $a) = unpack "A$al A*", $a; - push @tmp, "$p: $bit"; - $p = ' ' x ($l - 2); - } - push @tmp, "$p: $a" if length $a; + @tmp = split/\n/, Text::Wrap::wrap("$p: ", (' ' x $promptl) . ': ', $a); } else { push @tmp, $ans; } @@ -280,6 +285,7 @@ sub shellregex { my $in = shift; $in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge; + $in =~ s|\\/|/|g; return '^' . $in . "\$"; } @@ -383,14 +389,15 @@ sub unpad sub is_callsign { 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?[A-Z]{1,2}\d{0,2}/)? # out of area prefix / + (?:\d?[A-Z]{1,2}\d{1,5}) # main prefix one (required) - lengthened for special calls + [A-Z]{1,8} # callsign letters (required) (?:-(?:\d{1,2}))? # - nn possibly (eg G8BPQ-8) (?:/[0-9A-Z]{1,7})? # / another prefix, callsign or special label (including /MM, /P as well as /EURO or /LGT) possibly - $!x; + (?:/(?:AM?|MM?|P))? # finally /A /AM /M /MM /P + $!xo; - # longest callign allowed is 1X11/1Y11XXXXX-11/XXXXXXX + # longest callign allowed is 1X11/1Y11XXXXX-11/XXXXXXX/MM } sub is_prefix @@ -478,19 +485,20 @@ sub deleteitem sub localdata { my $ifn = shift; - my $ofn = "$main::local_data/$ifn"; - my $tfn; + my $lfn = "$main::local_data/$ifn"; + my $dfn = "$main::data/$ifn"; if (-e "$main::local_data") { - $tfn = "$main::data/$ifn"; - if ((-e $tfn) && (-e $ofn)) { - $ofn = $tfn if -M $ofn < -M $tfn; + if ((-e $dfn) && (-e $lfn)) { + $lfn = $dfn if -M $dfn < -M $lfn; } else { - $ofn = $tfn if -e $tfn; + $lfn = $dfn if -e $dfn; } + } else { + $lfn = $dfn; } - return $ofn; + return $lfn; } # move a file or a directory from data -> local_data if isn't there already @@ -514,6 +522,16 @@ sub _diffms return $b - $a; } +# and in microseconds +sub _diffus +{ + my $ta = shift; + my $tb = shift || [gettimeofday]; + my $a = int($ta->[0] * 1000000) + int($ta->[1]); + my $b = int($tb->[0] * 1000000) + int($tb->[1]); + return $b - $a; +} + sub diffms { my $call = shift; @@ -539,7 +557,7 @@ sub difft if (ref $b eq 'ARRAY') { $t = $b->[1] - $b->[0]; } else { - if ($adds >= $b) { + if ($adds && $adds =~ /^\d+$/ && $adds >= $b) { $t = $adds - $b; $adds = shift; } else { @@ -547,8 +565,11 @@ sub difft } } return '-(ve)' if $t < 0; - my ($d,$h,$m,$s); + my ($y,$d,$h,$m,$s); my $out = ''; + $y = int $t / (86400*365); + $out .= sprintf ("%s${y}y", $adds?' ':'') if $y; + $t -= $y * 86400 * 365; $d = int $t / 86400; $out .= sprintf ("%s${d}d", $adds?' ':'') if $d; $t -= $d * 86400; @@ -562,6 +583,7 @@ sub difft $out .= sprintf ("%s${s}s", $adds?' ':'') if $s; $out ||= sprintf ("%s0s", $adds?' ':''); } + $out = '0s' unless length $out; return $out; } @@ -577,3 +599,18 @@ sub parraydifft $out =~ s/,\s*$//; return $out; } + +sub basecall +{ + my ($r) = $_[0] =~ m{^((?:[\w\d]+/)?[\w\d]+(?:/[\w\d]+)*)(?:-\d+)?(?:-\#)?$}; + return $r; +} + +sub normalise_call +{ + my ($c, $ssid) = $_[0] =~ m|^((?:[\w\d]+/)?[\d\w]+(?:/[\w\d]+)*)(?:-(\d+))?(?:-\#)?$|; + my $ncall = $c; + $ssid += 0; + $ncall .= "-$ssid" if $ssid; + return $ncall; +}