From: Dirk Koopman <djk@tobit.co.uk>
Date: Fri, 9 Mar 2012 22:20:03 +0000 (+0000)
Subject: Merge PC34 unbless ref changes from main line
X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=commitdiff_plain;h=6951e5c6623c813b5f3da77796aa22c7e0848e44;hp=-c;p=spider.git

Merge PC34 unbless ref changes from main line

Conflicts:
	perl/DXUser.pm
---

6951e5c6623c813b5f3da77796aa22c7e0848e44
diff --combined perl/DXUser.pm
index c273970b,6cd6ca4f..84b6df3d
--- a/perl/DXUser.pm
+++ b/perl/DXUser.pm
@@@ -9,6 -9,7 +9,6 @@@
  package DXUser;
  
  use DXLog;
 -use DB_File;
  use Data::Dumper;
  use Fcntl;
  use IO::File;
@@@ -18,11 -19,10 +18,11 @@@ use LRU
  
  use strict;
  
 -use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3);
 +use vars qw(%u $dbm $dbh $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3 $v4);
  
  %u = ();
  $dbm = undef;
 +$dbh = undef;
  $filename = undef;
  $lastoperinterval = 60*24*60*60;
  $lasttime = 0;
@@@ -30,8 -30,6 +30,8 @@@ $lrusize = 2000
  $tooold = 86400 * 365;		# this marks an old user who hasn't given enough info to be useful
  $v3 = 0;
  
 +my $dbh_working;
 +
  # hash of valid elements and a simple prompt
  %valid = (
  		  call => '0,Callsign',
@@@ -123,95 -121,46 +123,95 @@@ sub ini
  
  	my $ufn;
  	my $convert;
 -	
 +
  	eval {
 -		require Storable;
 +		require DBI;
 +		require DBD::SQLite;
 +		require JSON;
  	};
 -
 -#	eval "use Storable qw(nfreeze thaw)";
  	
  	if ($@) {
 -		$ufn = "$fn.v2";
 -		$v3 = $convert = 0;
 -		dbg("the module Storable appears to be missing!!");
 +		
 +		$ufn = "$fn.v3";
 +		$v3 = 1; $convert = 0;
 +		dbg("One of more of the modules DBI, DBD::SQLite and JSON appear to be missing!!");
  		dbg("trying to continue in compatibility mode (this may fail)");
 -		dbg("please install Storable from CPAN as soon as possible");
 +		dbg("please install DBI, DBD::SQLite and JSON from CPAN as soon as possible");
 +
 +		eval {
 +			require DB_File;
 +			require Storable;
 +		};
 +
 +		if ($@) {
 +			$ufn = "$fn.v2";
 +			$v3 = $convert = 0;
 +			dbg("One of the modules DB_File and Storable appears to be missing!!");
 +			dbg("trying to continue in compatibility mode (this may fail)");
 +			dbg("please install Storable from CPAN as soon as possible");
 +		} else {
 +			import DB_File;
 +			import Storable qw(nfreeze thaw);
 +			
 +			$ufn = "$fn.v3";
 +			$v3 = 1;
 +			$convert++ if -e "$fn.v2" && !-e $ufn;
 +		}
  	} else {
 -		import Storable qw(nfreeze thaw);
 +		import DBI;
 +		import DBD::SQLite;
 +		import JSON qw(-convert_blessed_universally);
 +		
 +		$ufn = "$fn.v4";
 +		$v4 = 1;
 +		$convert++ if -e "$fn.v3" && !-e $ufn;
 +	}
  
 -		$ufn = "$fn.v3";
 -		$v3 = 1;
 -		$convert++ if -e "$fn.v2" && !-e $ufn;
 +	$main::systime ||= time;	# becuase user_asc doesn't set it
 +
 +	# open "database" files
 +	if ($v3) {
 +		if ($mode) {
 +			$dbm = tie (%u, 'DB_File', "$fn.v3", O_CREAT|O_RDWR, 0666, $DB::File::DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
 +		} else {
 +			$dbm = tie (%u, 'DB_File', "$fn.v3", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
 +		}
 +		die "Cannot open $fn.v3 ($!)\n" unless $dbm;
  	}
 -	
 -	if ($mode) {
 -		$dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
 -	} else {
 -		$dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
 +	if ($v4) {
 +		my $new = ! -e $ufn;
 +		$dbh = DBI->connect("dbi:SQLite:dbname=$ufn","","") or die "Cannot open $ufn ($!)\n";
 +		if ($new) {
 +			# create the table
 +			my $table = q{create table user(
 +call text not null unique,
 +lastseen int not null,
 +data text not null
 +)};
 +			$dbh->do($table) or die "cannot create user table in $ufn " . $dbh->errstr;
 +			
 +			# Add indexes
 +			$dbh->do(q(create index x1 on user(lastseen))) or die $dbh->errstr;
 +		}
 +		$dbh->do(q{PRAGMA cache_size = 8000});
 +		$dbh->do(q{PRAGMA synchronous = OFF});
  	}
  
 -	die "Cannot open $ufn ($!)\n" unless $dbm;
  
 -	$lru = LRU->newbase("DXUser", $lrusize);
 -	
  	# do a conversion if required
 -	if ($dbm && $convert) {
 +	if ($dbm && $v3 && $convert) {
  		my ($key, $val, $action, $count, $err) = ('','',0,0,0);
 +
 +		require DB_File;
 +		require Storable;
 +		import DB_File;
 +		import Storable qw(nfreeze thaw);
  		
  		my %oldu;
  		dbg("Converting the User File to V3 ");
 -		dbg("This will take a while, I suggest you go and have cup of strong tea");
 -		my $odbm = tie (%oldu, 'DB_File', "$fn.v2", O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn.v2 ($!) [rebuild it from user_asc?]";
 -        for ($action = R_FIRST; !$odbm->seq($key, $val, $action); $action = R_NEXT) {
 +		dbg("This will take a while, I suggest you go and have a cup of strong tea");
 +		my $odbm = tie (%oldu, 'DB_File', "$fn.v2", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn.v2 ($!) [rebuild it from user_asc?]";
 +        for ($action = DB_File::R_FIRST(); !$odbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) {
  			my $ref = asc_decode($val);
  			if ($ref) {
  				$ref->put;
@@@ -224,44 -173,6 +224,44 @@@
  		untie %oldu;
  		dbg("Conversion completed $count records $err errors");
  	}
 +
 +	if ($dbh && $v4 && $convert) {
 +		my ($key, $val, $action, $count, $err) = ('','',0,0,0);
 +		
 +		
 +		my %oldu;
 +		dbg("Converting the User File to V4 ");
 +		dbg("This will take a while, I suggest you go and have a cup of strong tea");
 +		require DB_File;
 +		require Storable;
 +		import DB_File;
 +		import Storable qw(nfreeze thaw);
 +		my $odbm = tie (%oldu, 'DB_File', "$fn.v3", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn.v3 ($!) [rebuild it from user_asc?]";
 +		$dbh->begin_work;
 +		$dbh_working++;
 +        for ($action = DB_File::R_FIRST(); !$odbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) {
 +			my $ref = thaw($val);
 +			if ($ref) {
 +				my $r = _insert($ref);
 +				if ($r) {
 +					$count++;
 +				} else {
 +					$err++;
 +					dbg("error converting call $ref->{call} - " . $dbh->errstr);
 +				}
 +			} else {
 +				$err++
 +			}
 +		}
 +		sync();
 +		undef $odbm;
 +		untie %oldu;
 +		dbg("Conversion completed $count records $err errors");
 +
 +	}
 +
 +	$lru = LRU->newbase("DXUser", $lrusize);
 +	
  	$filename = $ufn;
  }
  
@@@ -270,11 -181,7 +270,11 @@@ sub del_fil
  	my ($pkg, $fn) = @_;
    
  	confess "need a filename in User" if !$fn;
 -	$fn .= $v3 ? ".v3" : ".v2";
 +	my $suffix;
 +	$suffix = '.v4' if $v4;
 +	$suffix ||= '.v3' if $v3;
 +	$suffix ||= '.v2';
 +	$fn .= $suffix;
  	unlink $fn;
  }
  
@@@ -283,8 -190,8 +283,8 @@@
  #
  sub process
  {
 -	if ($main::systime > $lasttime + 15) {
 -		$dbm->sync;
 +	if ($main::systime > $lasttime + 5) {
 +		sync();
  		$lasttime = $main::systime;
  	}
  }
@@@ -295,11 -202,8 +295,11 @@@
  
  sub finish
  {
 -	undef $dbm;
 -	untie %u;
 +	if ($dbm) {
 +		undef $dbm;
 +		untie %u;
 +	}
 +	$dbh->disconnect if $dbh; 
  }
  
  #
@@@ -311,38 -215,9 +311,38 @@@ sub allo
  	my $pkg = shift;
  	my $call = uc shift;
  	my $self = bless {call => $call, 'sort'=>'U'}, $pkg;
 +	_insert($self) or confess($dbh->errstr) if $v4;
  	return $self;
  }
  
 +sub _insert
 +{
 +	my $self = shift;
 +	my $json = JSON->new->allow_blessed->convert_blessed->encode($self);
 +	$dbh->begin_work unless $dbh_working++;
 +	my $r = $dbh->do(q{replace into user values(?,?,?)}, undef, $self->{call}, $main::systime, $json);
 +	return $r;
 +}
 +
 +sub _select
 +{
 +	my $call = shift;
 +	my $sth = $dbh->prepare(qq{select data from user where call = ?}) or confess($dbh->errstr);
 +	my $rv = $sth->execute($call);
 +	if ($rv) {
 +		my @row = $sth->fetchrow_array;
 +		return $row[0];
 +	}
 +	return undef;
 +}
 +
 +sub _delete
 +{
 +	my $call =shift;
 +	my $r = $dbh->do(q{delete from user where call = ?}, undef, $call);
 +	return $r;
 +}
 +
  sub new
  {
  	my $pkg = shift;
@@@ -352,7 -227,7 +352,7 @@@
  #	confess "can't create existing call $call in User\n!" if $u{$call};
  
  	my $self = $pkg->alloc($call);
 -	$self->put;
 +	$self->put unless $v4;
  	return $self;
  }
  
@@@ -371,29 -246,21 +371,27 @@@ sub ge
  	return $ref if $ref && ref $ref eq 'DXUser';
  	
  	# search for it
 -	unless ($dbm->get($call, $data)) {
 -		$ref = decode($data);
 -		if ($ref) {
 -			if (UNIVERSAL::isa($ref, 'DXUser')) {
 -				dbg("DXUser::get: got strange answer from decode of $call". ref $ref. " ignoring");
 -				return undef;
 -			}
 -			# we have a reference and it *is* a DXUser
 -		} else {
 -			dbg("DXUser::get: no reference returned from decode of $call $!");
 +	if ($v4) {
 +		if ($data = _select($call)) {
- 			$ref = bless decode_json($data), __PACKAGE__;
- 			$lru->put($call, $ref);
- 			return $ref;
++			$ref = bless decode_json($data), 'DXUser';
 +		}
 +	} else {
 +	    unless ($dbm->get($call, $data)) {
 +			$ref = decode($data);
- 			if ($ref) {
- 				if (ref $ref ne 'DXUser') {
- 					dbg("DXUser::get: got strange answer from decode ". ref $ref. " ignoring");
- 					return undef;
- 				}
- 			} else {
- 				dbg("DXUser::get: no reference returned from decode $!");
- 				return undef;
- 			}
- 			$lru->put($call, $ref);
- 			return $ref;
 +		}
 +	}
 +	
++	if ($ref) {
++		if (UNIVERSAL::isa($ref, 'DXUser')) {
++			dbg("DXUser::get: got strange answer from decode of $call". ref $ref. " ignoring");
+ 			return undef;
+ 		}
 -		$lru->put($call, $ref);
 -		return $ref;
++		# we have a reference and it *is* a DXUser
++	} else {
++		dbg("DXUser::get: no reference returned from decode of $call $!");
++		return undef;
+ 	}
++	$lru->put($call, $ref);
  	return undef;
  }
  
@@@ -412,9 -279,9 +410,9 @@@ sub get_curren
  	my $dxchan = DXChannel::get($call);
  	if ($dxchan) {
  		my $ref = $dxchan->user;
- 		return $ref if ref $ref eq 'DXUser';
+ 		return $ref if $ref && UNIVERSAL::isa($ref, 'DXUser');
  
- 		dbg("DXUser::get_current: got invalid user ref from dxchan $dxchan->{call} ". ref $ref. " ignoring");
+ 		dbg("DXUser::get_current: got invalid user ref for $call from dxchan $dxchan->{call} ". ref $ref. " ignoring");
  	}
  	return get($call);
  }
@@@ -425,20 -292,7 +423,20 @@@
  
  sub get_all_calls
  {
 -	return (sort keys %u);
 +	if ($v4) {
 +		my $sth = $dbh->prepare(qq{select call from user}) or confess($dbh->errstr);
 +		my $rv = $sth->execute();
 +		if ($rv) {
 +			my @row;
 +			my @r;
 +			while (my @r = $sth->fetchrow_array) {
 +				push @row, @r;
 +			}
 +			return @row;		# 'cos it's already sorted
 +		}
 +	} else {
 +		return (sort keys %u);
 +	}
  }
  
  #
@@@ -451,17 -305,13 +449,17 @@@ sub pu
  	confess "Trying to put nothing!" unless $self && ref $self;
  	my $call = $self->{call};
  
 -	$dbm->del($call);
  	delete $self->{annok} if $self->{annok};
  	delete $self->{dxok} if $self->{dxok};
  
  	$lru->put($call, $self);
 -	my $ref = $self->encode;
 -	$dbm->put($call, $ref);
 +	if ($v4) {
 +		_insert($self);
 +	} else {
 +		$dbm->del($call);
 +		my $ref = $self->encode;
 +		$dbm->put($call, $ref);
 +	}
  }
  
  # freeze the user
@@@ -524,13 -374,9 +522,13 @@@ sub asc_decod
  sub del
  {
  	my $self = shift;
 -	my $call = $self->{call};
 -	$lru->remove($call);
 -	$dbm->del($call);
 +	if ($v4) {
 +		_delete($self)
 +	} else {
 +		my $call = $self->{call};
 +		$lru->remove($call);
 +		$dbm->del($call);
 +	}
  }
  
  #
@@@ -541,7 -387,7 +539,7 @@@ sub clos
  {
  	my $self = shift;
  	$self->{lastin} = time;
 -	$self->put();
 +	$self->put;
  }
  
  #
@@@ -550,12 -396,7 +548,12 @@@
  
  sub sync
  {
 -	$dbm->sync;
 +	if ($v4) {
 +		$dbh->commit if $dbh_working;
 +		$dbh_working = 0;
 +	} else {
 +		$dbm->sync;
 +	}
  }
  
  #
@@@ -589,6 -430,9 +587,6 @@@ sub expor
  	my $del = 0;
  	my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
  	if ($fh) {
 -		my $key = 0;
 -		my $val = undef;
 -		my $action;
  		my $t = scalar localtime;
  		print $fh q{#!/usr/bin/perl
  #
@@@ -655,76 -499,40 +653,76 @@@ print "There are $count user records an
  };
  		print $fh "__DATA__\n";
  
 -        for ($action = R_FIRST; !$dbm->seq($key, $val, $action); $action = R_NEXT) {
 -			if (!is_callsign($key) || $key =~ /^0/) {
 -				my $eval = $val;
 -				my $ekey = $key;
 -				$eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; 
 -				$ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; 
 -				LogDbg('DXCommand', "Export Error1: $ekey\t$eval");
 -				eval {$dbm->del($key)};
 -				dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@;
 -				++$err;
 -				next;
 -			}
 -			my $ref = decode($val);
 -			if ($ref) {
 -				my $t = $ref->{lastin} || 0;
 -				if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) {
 -					unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
 -						eval {$dbm->del($key)};
 -						dbg(carp("Export Error2: $key\t$val\n$@")) if $@;
 -						LogDbg('DXCommand', "$ref->{call} deleted, too old");
 -						$del++;
 +		if ($v4) {
 +			my $sth = $dbh->prepare(q{select call,data from user}) or confess($dbh->errstr);
 +			my $rv = $sth->execute;
 +			if ($rv) {
 +				while (my @row = $sth->fetchrow_array) {
 +					my $call = shift @row;
 +					my $data = shift @row;
 +					if (!is_callsign($call) || $call =~ /^0/) {
 +						LogDbg('DXCommand', "Export Error1: $call\t$data");
 +						_delete($call);
 +						++$err;
  						next;
  					}
 +					my $ref = bless decode_json($data), __PACKAGE__;
 +					my $t = $ref->{lastin} || 0;
 +					if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) {
 +						unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
 +							LogDbg('DXCommand', "$ref->{call} deleted, too old");
 +							_delete($call);
 +							$del++;
 +							next;
 +						}
 +					}
 +	
 +					# only store users that are reasonably active or have useful information
 +					print $fh "$call\t" . $ref->asc_encode($basic_info_only) . "\n";
 +					++$count;
  				}
 -				# only store users that are reasonably active or have useful information
 -				print $fh "$key\t" . $ref->asc_encode($basic_info_only) . "\n";
 -				++$count;
  			} else {
 -				LogDbg('DXCommand', "Export Error3: $key\t$val");
 -				eval {$dbm->del($key)};
 -				dbg(carp("Export Error3: $key\t$val\n$@")) if $@;
 -				++$err;
 +				dbg(carp($dbh->errstr));
  			}
 -		} 
 +		} else {
 +			my $key = 0;
 +			my $val = undef;
 +			my $action;
 +			for ($action = DB_File::R_FIRST(); !$dbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) {
 +				if (!is_callsign($key) || $key =~ /^0/) {
 +					my $eval = $val;
 +					my $ekey = $key;
 +					$eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; 
 +					$ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; 
 +					LogDbg('DXCommand', "Export Error1: $ekey\t$eval");
 +					eval {$dbm->del($key)};
 +					dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@;
 +					++$err;
 +					next;
 +				}
 +				my $ref = decode($val);
 +				if ($ref) {
 +					my $t = $ref->{lastin} || 0;
 +					if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) {
 +						unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
 +							eval {$dbm->del($key)};
 +							dbg(carp("Export Error2: $key\t$val\n$@")) if $@;
 +							LogDbg('DXCommand', "$ref->{call} deleted, too old");
 +							$del++;
 +							next;
 +						}
 +					}
 +					# only store users that are reasonably active or have useful information
 +					print $fh "$key\t" . $ref->asc_encode($basic_info_only) . "\n";
 +					++$count;
 +				} else {
 +					LogDbg('DXCommand', "Export Error3: $key\t$val");
 +					eval {$dbm->del($key)};
 +					dbg(carp("Export Error3: $key\t$val\n$@")) if $@;
 +					++$err;
 +				}
 +			} 
 +		}
          $fh->close;
      } 
  	return "$count Users $del Deleted $err Errors ('sh/log Export' for details)";