X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?p=spider.git;a=blobdiff_plain;f=perl%2FDXUtil.pm;h=f0e7a8ae00a341f04b5d35153b3a39a363a9b73f;hp=21ae3e2354e620b7607e265adcf8c747cdb76ad0;hb=d8d7d25e92a56847754a237166ca926adc2199ca;hpb=647730580f6fe6ad14ee8445f0d5d583390cb130

diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm
index 21ae3e23..f0e7a8ae 100644
--- a/perl/DXUtil.pm
+++ b/perl/DXUtil.pm
@@ -3,23 +3,36 @@
 #
 # 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 Text::Wrap;
+
+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 _diffms _diffus difft parraydifft is_ztime basecall
+			 normalise_call is_numeric
             );
 
+
 @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
 %patmap = (
 		   '*' => '.*',
@@ -28,6 +41,11 @@ require Exporter;
 		   ']' => ']'
 );
 
+$pi = 3.141592653589;
+$d2r = ($pi/180);
+$r2d = (180/$pi);
+
+
 # a full time for logging and other purposes
 sub atime
 {
@@ -120,10 +138,26 @@ 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
 {
-	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
@@ -131,21 +165,38 @@ 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($] < 5.005 ? 1 : 0);
-		$value = $dd->Dumpxs;
+		$value = dd($value);
 	}
-	$prompt = sprintf "%15s: %s", $prompt, $value;
+	$promptl ||= 15;
+	$prompt = sprintf "%${promptl}s: %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 .= "$_=" . atime($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(', ', sort @{$ref}) : $ref;
 }
 
 # take the arg as an array reference and print as a list of pairs
@@ -154,7 +205,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 +216,27 @@ sub parraypairs
 	return $out;
 }
 
+# take the arg as a hash reference and print it out as such
+sub phash
+{
+	my $ref = shift;
+	my $out;
+
+	foreach my $k (sort keys %$ref) {
+		$out .= "${k}=>$ref->{$k}, ";
+	}
+	$out =~ s/, $// if $out;
+	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 '<priv>,<prompt>[,<action>'
@@ -177,21 +249,27 @@ sub print_all_fields
 	my @out;
 	my @fields = $ref->fields;
 	my $field;
+	my $width = $self->width - 1;
+	my $promptl = 0;
+	$width ||= 80;
 
-	foreach $field (sort {$ref->field_prompt($a) cmp $ref->field_prompt($b)} @fields) {
+	# find the maximum length of the prompt
+	foreach $field (@fields) {
 		if (defined $ref->{$field}) {
-			my ($priv, $ans) = promptf($ref->field_prompt($field), $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}, $promptl);
 			my @tmp;
-			if (length $ans > 79) {
-				my ($p, $a) = split /: /, $ans;
-				my $l = (length $p) + 2;
-				my $al = 79 - $l;
-				while (length $a > $al ) {
-					$a =~ s/^(.{$al})//;
-					push @tmp, "$p: $1";
-					$p = ' ' x ($l - 2);
-				}
-				push @tmp, "$p: $a" if length $a;
+			if (length $ans > $width) {
+				$Text::Wrap::columns = $width-2;
+				my ($p, $a) = split /: /, $ans, 2;
+				@tmp = split/\n/, Text::Wrap::wrap("$p: ", (' ' x $promptl) . ': ', $a);
 			} else {
 				push @tmp, $ans;
 			}
@@ -207,18 +285,10 @@ sub shellregex
 {
 	my $in = shift;
 	$in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
+	$in =~ s|\\/|/|g;
 	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 +371,11 @@ sub writefilestr
 	}
 }
 
+sub filecopy
+{
+	copy(@_) or return $!;
+}
+
 # remove leading and trailing spaces from an input string
 sub unpad
 {
@@ -313,13 +388,30 @@ sub unpad
 # check that a field only has callsign characters in it
 sub is_callsign
 {
-	return $_[0] =~ /^[A-Z0-9\-]+$/;
+	return $_[0] =~ m!^
+					  (?:\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
+					  (?:/(?:AM?|MM?|P))?       # finally /A /AM /M /MM /P 
+					  $!xo;
+
+	# longest callign allowed is 1X11/1Y11XXXXX-11/XXXXXXX/MM
 }
 
+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 +423,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 +432,31 @@ 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] =~  /^(?:[\da-f]{1,4}:|:)(?:\:[0-9a-f]{1,4}){1,6}/i ;
+}
+
+# is it a zulu time hhmmZ
+sub is_ztime
+{
+	return $_[0] =~ /^(?:(?:2[0-3])|(?:[01][0-9]))[0-5][0-9]Z$/;
+}
+
 # insert an item into a list if it isn't already there returns 1 if there 0 if not
 sub insertitem
 {
@@ -361,3 +478,144 @@ 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 $lfn = "$main::local_data/$ifn";
+	my $dfn =  "$main::data/$ifn";
+	
+	if (-e "$main::local_data") {
+		if ((-e $dfn) && (-e $lfn)) {
+			$lfn = $dfn if -M $dfn < -M $lfn;
+		} else {
+			$lfn = $dfn if -e $dfn;
+		}
+	} else {
+		$lfn = $dfn;
+	}
+
+	return $lfn;
+}
+
+# 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 $ta = 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);
+	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;
+	my $line = shift;
+	my $ta = shift;
+	my $no = shift;
+	my $tb = shift;
+	my $msecs = _diffms($ta, $tb);
+
+	$line =~ s|\s+$||;
+	my $s = "subprocess stats cmd: '$line' $call ${msecs}mS";
+	$s .= " $no lines" if $no;
+	DXDebug::dbg($s);
+}
+
+# expects either an array reference or two times (in the correct order [start, end])
+sub difft
+{
+	my $b = shift;
+	my $adds = shift;
+	
+	my $t;
+	if (ref $b eq 'ARRAY') {
+		$t = $b->[1] - $b->[0];
+	} else {
+		if ($adds && $adds =~ /^\d+$/ && $adds >= $b) {
+			$t = $adds - $b;
+			$adds = shift;
+		} else {
+			$t = $main::systime - $b;
+		}
+	}
+	return '-(ve)' if $t < 0;
+	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;
+	$h = int $t / 3600;
+	$out .= sprintf ("%s${h}h", $adds?' ':'') if $h;
+	$t -= $h * 3600;
+	$m = int $t / 60;
+	$out .= sprintf ("%s${m}m", $adds?' ':'') if $m;
+	if ($d == 0 && $adds || $adds == 2) {
+		$s = int $t % 60;
+		$out .= sprintf ("%s${s}s", $adds?' ':'') if $s;
+		$out ||= sprintf ("%s0s", $adds?' ':'');
+	}
+	$out = '0s' unless length $out;
+	return $out;
+}
+
+# print an array ref of difft refs
+sub parraydifft
+{
+	my $r = shift;
+	my $out = '';
+	for (@$r) {
+		my $s = $_->[2] ? "($_->[2])" : '';
+		$out .= sprintf "%s=%s$s, ", atime($_->[0]), difft($_->[0], $_->[1]);
+	}
+	$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;
+}
+
+sub is_numeric
+{
+	return $_[0] =~ /^\d+$/;
+}