X-Git-Url: http://git.indexdata.com/?p=irspy-moved-to-github.git;a=blobdiff_plain;f=lib%2FZOOM%2FIRSpy.pm;h=aad702c337e40d7fc2895da6592c0ccfcc90d9d8;hp=bbf251d7a5ee8fd3dca695b69782bd5c4f67a469;hb=9f74222ecbca15c4ca23236b07c08c2ced5d2430;hpb=cdb62d58a17e0066756fa8d2c8d25b19a1894fdf
diff --git a/lib/ZOOM/IRSpy.pm b/lib/ZOOM/IRSpy.pm
index bbf251d..aad702c 100644
--- a/lib/ZOOM/IRSpy.pm
+++ b/lib/ZOOM/IRSpy.pm
@@ -1,4 +1,4 @@
-# $Id: IRSpy.pm,v 1.25 2006-10-11 16:44:04 mike Exp $
+# $Id: IRSpy.pm,v 1.31 2006-10-13 15:17:25 mike Exp $
package ZOOM::IRSpy;
@@ -7,12 +7,15 @@ use strict;
use warnings;
use Data::Dumper; # For debugging only
+use ZOOM;
+use Net::Z3950::ZOOM 1.13; # For the ZOOM version-check only
use ZOOM::IRSpy::Node;
use ZOOM::IRSpy::Connection;
use ZOOM::IRSpy::Record;
our @ISA = qw();
our $VERSION = '0.02';
+our $irspy_ns = 'http://indexdata.com/irspy/1.0';
# Enumeration for callback functions to return
@@ -44,10 +47,11 @@ protocols. It is a successor to the ZSpy program.
BEGIN {
ZOOM::Log::mask_str("irspy");
- ZOOM::Log::mask_str("irspy_test");
ZOOM::Log::mask_str("irspy_debug");
ZOOM::Log::mask_str("irspy_event");
ZOOM::Log::mask_str("irspy_unhandled");
+ ZOOM::Log::mask_str("irspy_test");
+ ZOOM::Log::mask_str("irspy_task");
}
sub new {
@@ -221,28 +225,27 @@ sub _render_record {
}
-sub _rewrite_records {
+sub _rewrite_record {
my $this = shift();
-
- # Write modified records back to database
- foreach my $conn (@{ $this->{connections} }) {
- my $rec = $conn->record();
- my $p = $this->{conn}->package();
- $p->option(action => "specialUpdate");
- my $xml = $rec->{zeerex}->toString();
- $p->option(record => $xml);
- $p->send("update");
- $p->destroy();
-
- $p = $this->{conn}->package();
- $p->send("commit");
- $p->destroy();
- if (0) {
- $xml =~ s/&/&/g;
- $xml =~ s//>/g;
- print "Updated with xml=
\n$xml
\n";
- }
+ my($conn) = @_;
+
+ $conn->log("irspy", "rewriting XML record");
+ my $rec = $conn->record();
+ my $p = $this->{conn}->package();
+ $p->option(action => "specialUpdate");
+ my $xml = $rec->{zeerex}->toString();
+ $p->option(record => $xml);
+ $p->send("update");
+ $p->destroy();
+
+ $p = $this->{conn}->package();
+ $p->send("commit");
+ $p->destroy();
+ if (0) {
+ $xml =~ s/&/&/g;
+ $xml =~ s//>/g;
+ print "Updated $conn with xml=
\n$xml
\n";
}
}
@@ -289,19 +292,27 @@ sub check {
while (1) {
my @copy_conn = @conn; # avoid alias problems after splice()
+ my $nconn = scalar(@copy_conn);
foreach my $i0 (0 .. $#copy_conn) {
my $conn = $copy_conn[$i0];
- #print "connection $i0 of ", scalar(@copy_conn), " from ", scalar(@conn), " is $conn\n";
+ #print "connection $i0 of $nconn/", scalar(@conn), " is $conn\n";
if (!$conn->current_task()) {
if (!$conn->next_task()) {
# Out of tasks: we need a new test
NEXT_TEST:
my $address = $conn->option("current_test_address");
- my $nextaddr = defined $address ?
- $this->_next_test($address) : "";
+ my $nextaddr;
+ if (!defined $address) {
+ $nextaddr = "";
+ } else {
+ $this->log("irspy_test",
+ "checking for next test after '$address'");
+ $nextaddr = $this->_next_test($address);
+ }
if (!defined $nextaddr) {
$conn->log("irspy", "has no more tests: removing");
splice @conn, $i0, 1;
+ $this->_rewrite_record($conn);
next;
}
@@ -309,7 +320,8 @@ sub check {
or die "invalid nextaddr '$nextaddr'";
$conn->option(current_test_address => $nextaddr);
my $tname = $node->name();
- $conn->log("irspy", "starting test '$nextaddr' = $tname");
+ $conn->log("irspy_test",
+ "starting test '$nextaddr' = $tname");
my $tasks = $conn->tasks();
my $oldcount = @$tasks;
"ZOOM::IRSpy::Test::$tname"->start($conn);
@@ -318,24 +330,26 @@ sub check {
# Prepare to start the first of the newly added tasks
$conn->next_task($tasks->[$oldcount]);
} else {
- $conn->log("irspy", "no tasks added by new test $tname");
+ $conn->log("irspy_task",
+ "no tasks added by new test $tname");
goto NEXT_TEST;
}
}
my $task = $conn->next_task();
die "no next task queued for $conn" if !defined $task;
- $conn->log("irspy", "starting task $task");
+ $conn->log("irspy_task", "starting task $task");
$conn->next_task(0);
$conn->current_task($task);
$task->run();
}
- ### Test $conn->is_idle() here?
+ # Do we need to test $conn->is_idle()? I don't think so!
}
my $i0 = ZOOM::event(\@conn);
- $this->log("irspy_event", "ZOOM_event(", scalar(@conn), " connections) = $i0");
+ $this->log("irspy_event",
+ "ZOOM_event(", scalar(@conn), " connections) = $i0");
last if $i0 == 0 || $i0 == -3; # no events or no connections
my $conn = $conn[$i0-1];
my $ev = $conn->last_event();
@@ -365,7 +379,7 @@ sub check {
if ($@) {
my $sub = $task->{cb}->{exception};
die $@ if !defined $sub;
- $res = &$sub($conn, $task, $@);
+ $res = &$sub($conn, $task, $task->udata(), $@);
} else {
my $sub = $task->{cb}->{$ev};
if (!defined $sub) {
@@ -373,7 +387,7 @@ sub check {
next;
}
- $res = &$sub($conn, $task, $ev);
+ $res = &$sub($conn, $task, $task->udata(), $ev);
}
if ($res == ZOOM::IRSpy::Status::OK) {
@@ -383,24 +397,25 @@ sub check {
my $task = $conn->current_task();
die "no task for TASK_DONE on $conn" if !$task;
die "next task already defined for $conn" if $conn->next_task();
- $conn->log("irspy", "completed task $task");
+ $conn->log("irspy_task", "completed task $task");
$conn->next_task($task->{next});
$conn->current_task(0);
} elsif ($res == ZOOM::IRSpy::Status::TEST_GOOD ||
$res == ZOOM::IRSpy::Status::TEST_BAD) {
my $x = ($res == ZOOM::IRSpy::Status::TEST_GOOD) ? "good" : "bad";
- $conn->log("irspy", "test completed ($x)");
+ $conn->log("irspy_test", "test completed ($x)");
$conn->current_task(0);
$conn->next_task(0);
- ### Should also skip over remaining sibling tests if TEST_BAD
- $nskipped += 1; # should count number of skipped siblings
+ if ($res == ZOOM::IRSpy::Status::TEST_BAD) {
+ ### Should skip over remaining sibling tests if TEST_BAD
+ ### Should count the number of skipped siblings
+ $nskipped += 1;
+ }
}
}
- $this->log("irspy_event", "no more events: finishing");
-
- #$this->_rewrite_records();
+ $this->log("irspy", "exiting main loop");
return $nskipped;
}
@@ -438,8 +453,6 @@ sub _next_test {
my $this = shift();
my($address, $omit_child) = @_;
- $this->log("irspy", "checking for next test after '$address'");
-
# Try first child
if (!$omit_child) {
my $maybe = $address eq "" ? "0" : "$address:0";