POMPUS

What is POMPUS?

P	ersistant
O	bject
M	odels in
P	erl
U	using
S	OAP

Problem

• How do I replicate a facility I had in another language/IDE (SNAP)?

Problem

• How do I replicate a facility I had in another language/IDE (SNAP)?

• Its nice to be able to create/destroy and modify objects within a program, but how can you do it dynamically?

Problem

• How do I replicate a facility I had in another language/IDE (SNAP)?

• Its nice to be able to create/destroy and modify objects within a program, but how can you do it dynamically?

• How can you asynchronously view the object instances in the middle of a run without adding debug code?

Problem

• How do I replicate a facility I had in another language/IDE (SNAP)?

• Its nice to be able to create/destroy and modify objects within a program, but how can you do it dynamically?

• How can you asynchronously view the object instances in the middle of a run without adding debug code?

  SOAP... a browser and a little magic.

Problem

• I want to replicate the:

  Model, View, Controller

  style of application...

Problem

• I want to replicate the:

  Model, View, Controller

  style of application...

• In Perl

Problem

• I want to replicate the:

  Model, View, Controller

  style of application...

• In Perl

• With multiple independant processes

Problem

• I want to replicate the:

  Model, View, Controller

  style of application...

• In Perl

• With multiple independant processes

• With multiple "views", and multiple "controllers".

Problem

• I want to replicate the:

  Model, View, Controller

  style of application...

• In Perl

• With multiple independant processes

• With multiple "views", and multiple "controllers".

• Allow browser based clients

The Need

The Theory

The Theory

• Notice the gap between the 'need' and the 'theory'?

The Implementation

Beginner's SOAP

#!/root/fulko/bin/perl
  use SOAP::Lite;
  print SOAP::Lite
    -> uri('http://www.soaplite.com/Temperatures')
    -> proxy('http://services.soaplite.com/temper.cgi')
    -> f2c(98.6)
    -> result;
print "\n";

Demo

• (soap0/1.pl)

My First Client

#!/root/fulko/bin/perl

use SOAP::Lite
	+autodispatch =>
	uri => 'http://wecan.com/Demo',
	proxy => 'tcp://localhost:2000',                  # local tcp server
	on_fault => sub { my($soap, $res) = @_;
	die ref $res ? $res->faultdetail : $soap->transport->status, "\n";
	};

while ($i++ < 2) {
	print hi();
	print bye();
}

print "hi count: ", num_hi(), " bye count = ", num_bye(), "\n";

My First Client

#!/root/fulko/bin/perl

use SOAP::Lite
	+autodispatch =>
	uri => 'http://wecan.com/Demo',
	proxy => 'tcp://localhost:2000',                  # local tcp server
	on_fault => sub { my($soap, $res) = @_;
	die ref $res ? $res->faultdetail : $soap->transport->status, "\n";
	};

while ($i++ < 2) {
	print hi();
	print bye();
}

print "hi count: ", num_hi(), " bye count = ", num_bye(), "\n";

Note: Remote methods are called as if they are local methods.

My First Server

#!/root/fulko/bin/perl -w

use SOAP::Transport::TCP;

my $daemon = SOAP::Transport::TCP::Server
	-> new (LocalAddr => 'localhost', LocalPort => 2000, Listen => 5, Reuse => 1)
	-> dispatch_to('Demo')
	-> handle;

My First Server

#!/root/fulko/bin/perl -w

use SOAP::Transport::TCP;

my $daemon = SOAP::Transport::TCP::Server
	-> new (LocalAddr => 'localhost', LocalPort => 2000, Listen => 5, Reuse => 1)
	-> dispatch_to('Demo')
	-> handle;

Note: Use the 'dispatch_to' to direct the server to a class in the @INC path.

My First Server (Part 2)

package Demo;

sub hi {
	print "hello, world\n";
	$hi_counter++;
	return "hello, world\n";
}

sub bye {
	print "goodbye, cruel world\n";
	$bye_counter++;
	return "goodbye, cruel world\n";
}

sub num_hi	{ return $hi_counter;	}
sub num_bye	{ return $bye_counter;	}

Demo

• (soap1/server)

• (soap1/client)

Server #2 (with modules)

#!/root/fulko/bin/perl -w

#use SOAP::Lite +trace;
use SOAP::Transport::TCP;

my $daemon = SOAP::Transport::TCP::Server
	-> new (LocalAddr => 'localhost', LocalPort => 2000, Listen => 5, Reuse => 1)
	-> dispatch_to('/home/fulko/programs/soap/soap2', 'Demo', 'Demo1', 'TestF')
	-> handle;

Server #2 (with modules)

#!/root/fulko/bin/perl -w

#use SOAP::Lite +trace;
use SOAP::Transport::TCP;

my $daemon = SOAP::Transport::TCP::Server
	-> new (LocalAddr => 'localhost', LocalPort => 2000, Listen => 5, Reuse => 1)
	-> dispatch_to('/home/fulko/programs/soap/soap2', 'Demo', 'Demo1', 'TestF')
	-> handle;

Note: Dispatch to multiple classes with security.

Server #2 (Demo.pm)

package Demo;

sub hi {
	print "hello, world\n";
	$hi_counter++;
	return "hello, world\n";
}

sub bye {
	print "goodbye, cruel world\n";
	$bye_counter++;
	return "goodbye, cruel world\n";
}

sub num_hi		{ return $hi_counter;	}
sub num_bye		{ return $bye_counter;	}

1;

Server #2 (Demo1.pm)

package Demo1;

sub hi_there {
	print "2nd module's hi\n";
	return "2nd module's hi\n";
}

sub bye_there {
	print "2nd module's bye\n";
	return "2nd module's bye\n";
}

1;

Server #2 (TestF.pm - Part 1)

package TestF;

use strict;
use vars qw($AUTOLOAD);		# keep 'use strict' happy
use Carp;

{
	my %_attr_data = (
		_first_name	=> "",
		_last_name	=> ""
	);

	my $_count = 0;
	sub _incr_count		{ print "incr called\n"; ++$_count; }
	sub _dec_count		{ print "decr called\n"; --$_count; }
	sub get_count		{ $_count; }
	sub _standard_keys	{ keys %_attr_data; }

	sub _default_for {
		my ($self, $attr) = @_;
		$_attr_data{$attr};
	}
}

Server #2 (TestF.pm - Part 2)

	sub new {
		my ($caller, %arg) = @_;
		my $caller_is_obj = ref($caller);
		my $class = $caller_is_obj || $caller;
		my $self = bless {}, $class;
		foreach my $attrname ( $self->_standard_keys() ) {
			my ($argname) = ($attrname =~ /^_(.*)/);
			if	(exists $arg{$argname})	{ $self->{$attrname} = $arg{$argname} }
			elsif	($caller_is_obj)	{ $self->{$attrname} = $caller->{$attrname} }
			else				{ $self->{$attrname} = $self->_default_for($attrname) }
		}
		$class->_incr_count();
		return $self;
	}

	sub DESTROY {
		$_[0]->_dec_count();
	}

Server #2 (TestF.pm - Part 3)

	sub AUTOLOAD {
		no strict "refs";
		my ($self, $newval) = @_;

		if ($AUTOLOAD =~ /.*::get(_\w+)/) {
			my $attr_name = $1;
			*{$AUTOLOAD} = sub {return $_[0]->{$attr_name} };
			return $self->{$attr_name};
		}

		if ($AUTOLOAD =~ /.*::set(_\w+)/) {
			my $attr_name = $1;
			*{$AUTOLOAD} = sub { $_[0]->{$attr_name} = $_[1]; return; };
			$self->{$1} = $newval;
			return;
		}
		croak "No such method: $AUTOLOAD";
	}
1;

Server #2 (TestF.pm - Part 3)

	sub AUTOLOAD {
		no strict "refs";
		my ($self, $newval) = @_;

		if ($AUTOLOAD =~ /.*::get(_\w+)/) {
			my $attr_name = $1;
			*{$AUTOLOAD} = sub {return $_[0]->{$attr_name} };
			return $self->{$attr_name};
		}

		if ($AUTOLOAD =~ /.*::set(_\w+)/) {
			my $attr_name = $1;
			*{$AUTOLOAD} = sub { $_[0]->{$attr_name} = $_[1]; return; };
			$self->{$1} = $newval;
			return;
		}
		croak "No such method: $AUTOLOAD";
	}
1;

Note: Use AUTOLOAD to auto-generate accessor methods.

Client #2

#!/root/fulko/bin/perl

use SOAP::Lite
#+trace => all,
	+autodispatch =>
	uri => 'http://wecan.com/',
	proxy => 'tcp://localhost:2000',                  # local tcp server
	on_fault => sub { my($soap, $res) = @_;
	die ref $res ? $res->faultdetail : $soap->transport->status, "\n";
	};

goto FIRST;

while ($i++ < 2) {
	print Demo::hi();
	print Demo::bye();
}

printf "hi count: %d, bye count = %d\n", Demo::num_hi(), Demo::num_bye();
FIRST:
print Demo1::hi_there();
print "\n\n";

my $person = TestF::new(first_name => 'Fulko', last_name => 'Hew');
print "object = $person\n";
print "Count: ", TestF::get_count(), "\n";
print $person->get_first_name(), " ", $person->get_last_name(), "\n";

Demo

• (soap2/server)

• (soap2/client)

Demo

• (soap2/server)

• (soap2/client)

   

• (soap2/server) with trace

• (soap2/client)

Problems

• objects are:

  • created on the client

  • serialized and sent to the server

  • processed/modified

  • serialized and returned to the client

• but we need our objects to persist in the server

Problems

• objects are:

  • created on the client

  • serialized and sent to the server

  • processed/modified

  • serialized and returned to the client

• but we need our objects to persist in the server

   

  Note: Alter the server's garbage collector.

Server #3

#!/root/fulko/bin/perl -w

{
package main;

use SOAP::Transport::TCP;

my $daemon = SOAP::Transport::TCP::Server
	-> new (LocalAddr => 'localhost', LocalPort => 2000, Listen => 5, Reuse => 1)
	-> objects_by_reference('TestF' => \&TestF::garbage_collector)
	-> dispatch_to('TestF')
	-> handle;
}

Server #3

#!/root/fulko/bin/perl -w

{
package main;

use SOAP::Transport::TCP;

my $daemon = SOAP::Transport::TCP::Server
	-> new (LocalAddr => 'localhost', LocalPort => 2000, Listen => 5, Reuse => 1)
	-> objects_by_reference('TestF' => \&TestF::garbage_collector)
	-> dispatch_to('TestF')
	-> handle;
}

Note: Use objects_by_references() to prevent object from being passed and use references instead.

Server #3 (Part 2)

package TestF;
use Data::Dumper;

my %_objhash = ();

sub new {
	my $class = $_[0];
	my $self = {
		_name => $_[1]
	};
	bless $self, $class;
	$_objhash{$self} = \$self;		# record this instance
	return $self;
}

sub set_name { $_[0]->{_name} = $_[1]; }
sub get_name { return $_[0]->{_name}; }

sub dump_obj_list 	{ keys (%_objhash); }
sub dump_by_ref 	{ "$_[0]:\n", Dumper($_[0]); }
sub dump_by_label	{ "$_[1]:\n", Dumper($_objhash{$_[1]}); }
sub get_count		{ scalar (keys %_objhash); }

Server #3 (Part 2)

package TestF;
use Data::Dumper;

my %_objhash = ();

sub new {
	my $class = $_[0];
	my $self = {
		_name => $_[1]
	};
	bless $self, $class;
	$_objhash{$self} = \$self;		# record this instance
	return $self;
}

sub set_name { $_[0]->{_name} = $_[1]; }
sub get_name { return $_[0]->{_name}; }

sub dump_obj_list 	{ keys (%_objhash); }
sub dump_by_ref 	{ "$_[0]:\n", Dumper($_[0]); }
sub dump_by_label	{ "$_[1]:\n", Dumper($_objhash{$_[1]}); }
sub get_count		{ scalar (keys %_objhash); }

Note: Add dumping via Data::Dumper.

continued...

Server #3 (Part 2)

package TestF;
use Data::Dumper;

my %_objhash = ();

sub new {
	my $class = $_[0];
	my $self = {
		_name => $_[1]
	};
	bless $self, $class;
	$_objhash{$self} = \$self;		# record this instance
	return $self;
}

sub set_name { $_[0]->{_name} = $_[1]; }
sub get_name { return $_[0]->{_name}; }

sub dump_obj_list 	{ keys (%_objhash); }
sub dump_by_ref 	{ "$_[0]:\n", Dumper($_[0]); }
sub dump_by_label	{ "$_[1]:\n", Dumper($_objhash{$_[1]}); }
sub get_count		{ scalar (keys %_objhash); }

Note: Add dumping via Data::Dumper.

  But Data::Dumper has issues.

Server #3 (Part 3)

	# use this routine on clients to forcably destroy objects on the server side.
	# it will also remove the reference from the 'persistent object' list

sub stooith {
	delete $_objhash{$_[0]};		# forget he ever existed
	$_[0] = undef;				# blow him away
}

	# this gets called if a server side object ever falls out of scope
	# normally, we would probably want to keep server side objects persistant

sub DESTROY {
	if (exists $::_objhash{$_[0]}) {
		delete $_objhash{$_[0]};	# forget he ever existed
	}
}

Server #3 (Part 3)

	# use this routine on clients to forcably destroy objects on the server side.
	# it will also remove the reference from the 'persistent object' list

sub stooith {
	delete $_objhash{$_[0]};		# forget he ever existed
	$_[0] = undef;				# blow him away
}

	# this gets called if a server side object ever falls out of scope
	# normally, we would probably want to keep server side objects persistant

sub DESTROY {
	if (exists $::_objhash{$_[0]}) {
		delete $_objhash{$_[0]};	# forget he ever existed
	}
}

Note: stoith() used by client to force a destruction.

continued...

Server #3 (Part 3)

	# use this routine on clients to forcably destroy objects on the server side.
	# it will also remove the reference from the 'persistent object' list

sub stooith {
	delete $_objhash{$_[0]};		# forget he ever existed
	$_[0] = undef;				# blow him away
}

	# this gets called if a server side object ever falls out of scope
	# normally, we would probably want to keep server side objects persistant

sub DESTROY {
	if (exists $::_objhash{$_[0]}) {
		delete $_objhash{$_[0]};	# forget he ever existed
	}
}

Note: stoith() used by client to force a destruction.

Note: destroy() needed to remove the last reference to our object held within the hash.

Server #3 (Part 4)

	# this routine gets called by soap::lite when it tries to auto garbage collect
	# since we don't want soap to garbage collect, we prevent objects on our
	# persistant list from dissapearing.  Client applications must use stooith()
	# to explicitly destroy them on the server.

sub garbage_collector {
	my( $number_of_objects_of_this_class,	# if you want to implement cache
		$current_time,
		$object,
		$type,				# ref $object (class name)
		$creation_time,			# cannot be undef
		$last_access_time,		# can be undef if not accessed
		) = @_;
	if (exists ($_objhash{$object})) {
		#print "left him around\n";
		0;				# 0 = don't destroy, leave it persistent
	} else {
		#print "destroyed $object\n";
		delete $_objhash{$object};	# forget he ever existed
		$object = undef;		# blow him away
		1;				# 1 = garbage collect it
	}
}
1;

Server #3 (Part 4)

	# this routine gets called by soap::lite when it tries to auto garbage collect
	# since we don't want soap to garbage collect, we prevent objects on our
	# persistant list from dissapearing.  Client applications must use stooith()
	# to explicitly destroy them on the server.

sub garbage_collector {
	my( $number_of_objects_of_this_class,	# if you want to implement cache
		$current_time,
		$object,
		$type,				# ref $object (class name)
		$creation_time,			# cannot be undef
		$last_access_time,		# can be undef if not accessed
		) = @_;
	if (exists ($_objhash{$object})) {
		#print "left him around\n";
		0;				# 0 = don't destroy, leave it persistent
	} else {
		#print "destroyed $object\n";
		delete $_objhash{$object};	# forget he ever existed
		$object = undef;		# blow him away
		1;				# 1 = garbage collect it
	}
}
1;

Note: garbage_collector() is run by SOAP::Lite. We need to overide it.

Client #3 (Part 1)

#!/root/fulko/bin/perl

use SOAP::Lite
	+autodispatch =>
	uri => 'http://wecan.com/',
	proxy => 'tcp://localhost:2000',                  # local tcp server
	on_fault => sub { my($soap, $res) = @_;
	die ref $res ? $res->faultdetail : $soap->transport->status, "\n";
	};

sub stooith {
	$_[0]->stooith();	# remote kill the remote object
	$_[0] = undef;		# kill local copy
}

my $obj = TestF->new('Fulko');
my $obj2 = TestF->new('Frank');
stooith($obj2);

Client #3 (Part 1)

#!/root/fulko/bin/perl

use SOAP::Lite
	+autodispatch =>
	uri => 'http://wecan.com/',
	proxy => 'tcp://localhost:2000',                  # local tcp server
	on_fault => sub { my($soap, $res) = @_;
	die ref $res ? $res->faultdetail : $soap->transport->status, "\n";
	};

sub stooith {
	$_[0]->stooith();	# remote kill the remote object
	$_[0] = undef;		# kill local copy
}

my $obj = TestF->new('Fulko');
my $obj2 = TestF->new('Frank');
stooith($obj2);

Note: Build two remote objects... destroy one.

Client #3 (Part 2)

print "object = $obj\n";
print "Count: ", TestF::get_count(), "\n";
print "Should be 'fulko': " . $obj->get_name() . "\n";

$obj->set_name('Bill');
print "Should be 'bill': " . $obj->get_name() . "\n";

print "list: ", join(', ', TestF::dump_obj_list()), "\n";
print "odump: ", $obj->dump_by_ref(), "\n";

#@list = TestF::dump_obj_list();
#foreach (@list) { print "odump: ", TestF::dump_by_label($_), "\n"; }

print "remote object destroyed\n";
print "Count: ", TestF::get_count(), "\n";
#print "Should be 'fulko': " . $obj->get_name() . "\n";		# this should fail

sleep 5;

Client #3 (Part 3)

print "firstlist: ", join(', ', TestF::dump_obj_list()), "\n";

for ($i = 0; $i < 1; $i++) {
	sleep 20;
	print "$i\n";
}
print "before: ", join(', ', TestF::dump_obj_list()), "\n";
#stooith($obj);
print "after: ", join(', ', TestF::dump_obj_list()), "\n";
print "Count: ", TestF::get_count(), "\n";

Demo

• (soap3/server)

• (soap3/client)

Timeout for a BUG

	# this test program validates or tests an issue with LHS versus RHS order of execution
	# w.r.t. a line of code in SOAP::lite in it's object_by_reference() subroutine.
	# Fulko Hew, Jan 24, 2003

my %alive;
sub myfunc { };

sub works {
	while (@_) {
		#print "inside_count: ", scalar(@_), "\n";
		#print "1:$_[0], 2:$_[1]\n";
		my $tmp = shift; $alive{$tmp} = ref $_[0] ? shift : sub { 1; }
		}
	while (($a, $b) = each %alive) { print "key: $a, value: $b\n";}
}

sub doesntwork {
	while (@_) {
		#print "inside_count: ", scalar(@_), "\n";
		#print "1:$_[0], 2:$_[1]\n";
		$alive {shift()} = ref $_[0] ? shift : sub { 1; }
		}
	while (($a, $b) = each %alive) { print "key: $a, value: $b\n";}
}

print "defined address: ", \&myfunc, "\n\n";
works('default1', 'default2', 'user1' => \&myfunc, 'user2' => \&myfunc, 'default3', 'user3' => \&myfunc,);
$alive = ();
print "\n";
doesntwork('default1', 'default2', 'user1' => \&myfunc, 'user2' => \&myfunc, 'default3', 'user3' => \&myfunc,);

Server #4

#!/root/fulko/bin/perl -w

{
package main;

use SOAP::Transport::TCP;

my $daemon = SOAP::Transport::TCP::Server
	-> new (LocalAddr => 'localhost', LocalPort => 2000, Listen => 5, Reuse => 1)
	-> objects_by_reference('TestF')
	-> dispatch_to('/home/fulko/programs/soap/soap4', 'TestF')
	-> handle;
}

Server #4 (Part 2)

package TestF;
use ClassWrapper;
@ISA = qw(ClassWrapper);

sub new {
	my $class = $_[0];
	my $self = {
		_name => $_[1]
	};
	bless $self, $class;
	$_objhash{$self} = \$self;			# record this instance
	return $self;
}

sub set_name { print "set_name()\n"; $_[0]->{_name} = $_[1]; }
sub get_name { print "get_name()\n"; return $_[0]->{_name}; }

1;

Server #4 (Part 2)

package TestF;
use ClassWrapper;
@ISA = qw(ClassWrapper);

sub new {
	my $class = $_[0];
	my $self = {
		_name => $_[1]
	};
	bless $self, $class;
	$_objhash{$self} = \$self;			# record this instance
	return $self;
}

sub set_name { print "set_name()\n"; $_[0]->{_name} = $_[1]; }
sub get_name { print "get_name()\n"; return $_[0]->{_name}; }

1;

Note: Formalize the generic object repository wrapper.

Server #4 (Part 3)

package ClassWrapper;
use Data::Dumper;

my %_objhash = ();

sub dump_obj_list 	{ keys (%_objhash); }
sub dump_by_ref 	{ "$_[0]:\n", Dumper($_[0]); }
sub dump_by_label	{ "$_[1]:\n", Dumper($_objhash{$_[1]}); }
sub get_count		{ print "get_count()\n"; scalar (keys %_objhash); }

	# use this routine on clients to forcably destroy objects on the server side.
	# it will also remove the reference from the 'persistent object' list

sub stooith {
	delete $_objhash{$_[0]};	# forget he ever existed
	$_[0] = undef;			# blow him away
}

	# this gets called if a server side object ever falls out of scope
	# normally, we would probably want to keep server side objects persistant

sub DESTROY {
	if (exists $::_objhash{$_[0]}) {
		delete $_objhash{$_[0]};	# forget he ever existed
	}
}

Server #4 (Part 3)

package ClassWrapper;
use Data::Dumper;

my %_objhash = ();

sub dump_obj_list 	{ keys (%_objhash); }
sub dump_by_ref 	{ "$_[0]:\n", Dumper($_[0]); }
sub dump_by_label	{ "$_[1]:\n", Dumper($_objhash{$_[1]}); }
sub get_count		{ print "get_count()\n"; scalar (keys %_objhash); }

	# use this routine on clients to forcably destroy objects on the server side.
	# it will also remove the reference from the 'persistent object' list

sub stooith {
	delete $_objhash{$_[0]};	# forget he ever existed
	$_[0] = undef;			# blow him away
}

	# this gets called if a server side object ever falls out of scope
	# normally, we would probably want to keep server side objects persistant

sub DESTROY {
	if (exists $::_objhash{$_[0]}) {
		delete $_objhash{$_[0]};	# forget he ever existed
	}
}

Note: Same stuff from previous examples.

Server #4 (Part 4)

	# this routine gets called by soap::lite when it tries to auto garbage collect
	# since we don't want soap to garbage collect, we prevent objects on our
	# persistant list from dissapearing.  Client applications must use stooith()
	# to explicitely destroy them on the server.

sub garbage_collector {
	my( $number_of_objects_of_this_class,	# if you want to implement cache
		$current_time,
		$object,
		$type,				# ref $object (class name)
		$creation_time,			# cannot be undef
		$last_access_time,		# can be undef if not accessed
		) = @_;
	if (exists ($_objhash{$object})) {
		#print "left him around\n";
		0;				# 0 = don't destroy, leave it persistent
	} else {
		#print "destroyed $object\n";
		delete $_objhash{$object};	# forget he ever existed
		$object = undef;		# blow him away
		1;				# 1 = garbage collect it
	}
}

1;

Server #4 (Part 4)

	# this routine gets called by soap::lite when it tries to auto garbage collect
	# since we don't want soap to garbage collect, we prevent objects on our
	# persistant list from dissapearing.  Client applications must use stooith()
	# to explicitely destroy them on the server.

sub garbage_collector {
	my( $number_of_objects_of_this_class,	# if you want to implement cache
		$current_time,
		$object,
		$type,				# ref $object (class name)
		$creation_time,			# cannot be undef
		$last_access_time,		# can be undef if not accessed
		) = @_;
	if (exists ($_objhash{$object})) {
		#print "left him around\n";
		0;				# 0 = don't destroy, leave it persistent
	} else {
		#print "destroyed $object\n";
		delete $_objhash{$object};	# forget he ever existed
		$object = undef;		# blow him away
		1;				# 1 = garbage collect it
	}
}

1;

Note: Same garbage collector too.

Client #4 (Part 1)

#!/root/fulko/bin/perl

use SOAP::Lite
	+autodispatch =>
	uri => 'http://wecan.com/',
	proxy => 'tcp://localhost:2000',         # local tcp server
	on_fault => sub { my($soap, $res) = @_;
	die ref $res ? $res->faultdetail : $soap->transport->status, "\n";
	};

sub stooith {
	$_[0]->stooith();
	$_[0] = undef;
}

Client #4 (Part 2)

my $obj = TestF->new('Fulko');
my $obj2 = TestF->new('Frank');
stooith($obj2);

print "object = $obj\n";
print "Should be 'fulko': " . $obj->get_name() . "\n";
print "Count: ", TestF::get_count(), "\n";

$obj->set_name('Bill');
print "Should be 'bill': " . $obj->get_name() . "\n";

print "list: ", join(', ', TestF::dump_obj_list()), "\n";
print "odump: ", $obj->dump_by_ref(), "\n";

#@list = TestF::dump_obj_list();
#foreach (@list) { print "odump: ", TestF::dump_by_label($_), "\n"; }

print "remote object destroyed\n";
print "Count: ", TestF::get_count(), "\n";
#print "Should be 'fulko': " . $obj->get_name() . "\n";		# this should fail

Client #4 (Part 3)

sleep 5;

print "firstlist: ", join(', ', TestF::dump_obj_list()), "\n";

for ($i = 0; $i < 1; $i++) {
	sleep 20;
	print "$i\n";
}
print "before: ", join(', ', TestF::dump_obj_list()), "\n";
#stooith($obj);
print "after: ", join(', ', TestF::dump_obj_list()), "\n";
print "Count: ", TestF::get_count(), "\n";

Demo

• (soap4/server)

• (soap4/client)

Final Server (Part 1)

#!/root/fulko/bin/perl -w

use warnings;
use strict;

package main;

use World;
use Country;
use City;

my %modules;
my ($world, $country, $city);

sub init {
	$world	= World->new('Default');	# create a new world by default
	$country = Country->new('Default');	# and a new default country
	$city	= City->new('Default');		# and city
}

Final Server (Part 2)

	# Warning:	Compile time errors are not shown by the server, so we run
	#		all of those modules through the compile time checker first

foreach (<*.pm>) {					# scan this directory
	my $res = `perl -c $_ 2>&1`;			# look for syntax errors in my modules first
    	if ($?) { print "$res"; exit; }			# and exit if there is an error
							# otherwise build a list of modules
	s/\.pm$//;					# based on the files found (without the .pm suffix)
	$modules{$_} = \&PersistObj::garbage_collector;	# its actually a hash to insert the collector routine
}
print "server running\n";
init();							# create whatever defaults are required

Final Server (Part 3)

use SOAP::Transport::TCP;

my $daemon = SOAP::Transport::TCP::Server
	-> new (LocalAddr => 'localhost', LocalPort => 2000, Listen => 5, Reuse => 1)
	-> objects_by_reference(%modules)	# a list of "'class' => \&PersistObj::garbage_collector"
	-> dispatch_to(keys %modules)
	-> handle;

Final Server (Part 3)

use SOAP::Transport::TCP;

my $daemon = SOAP::Transport::TCP::Server
	-> new (LocalAddr => 'localhost', LocalPort => 2000, Listen => 5, Reuse => 1)
	-> objects_by_reference(%modules)	# a list of "'class' => \&PersistObj::garbage_collector"
	-> dispatch_to(keys %modules)
	-> handle;

Note: objects_by_ref() is passed a list of garbage collectors, same one for each class.
continued...

Final Server (Part 3)

use SOAP::Transport::TCP;

my $daemon = SOAP::Transport::TCP::Server
	-> new (LocalAddr => 'localhost', LocalPort => 2000, Listen => 5, Reuse => 1)
	-> objects_by_reference(%modules)	# a list of "'class' => \&PersistObj::garbage_collector"
	-> dispatch_to(keys %modules)
	-> handle;

Note: objects_by_ref() is passed a list of garbage collectors, same one for each class.

Note: dispatch_to() is passed the class list (or keys)

Final Client (Part 1)

#!/root/fulko/bin/perl

use warnings;			# Don't warn about using AUTOLOAD for non-method subroutines, cause
no warnings "deprecated";	# SOAP::Lite's autodispatch depends on that "accidental feature"
use strict;

our ($remote_host, $remote_port);
BEGIN {
	$remote_host = 'localhost';
	$remote_port = '2000';
}

my $local = 0;         # Mode: 1=local execution, nz=use remote object server

Final Client (Part 1)

#!/root/fulko/bin/perl

use warnings;			# Don't warn about using AUTOLOAD for non-method subroutines, cause
no warnings "deprecated";	# SOAP::Lite's autodispatch depends on that "accidental feature"
use strict;

our ($remote_host, $remote_port);
BEGIN {
	$remote_host = 'localhost';
	$remote_port = '2000';
}

my $local = 0;         # Mode: 1=local execution, nz=use remote object server

Note: Try to localize/parameterize the server/port number, but it needs to be compile time set.

Final Client (Part 2)

if ($local) {
	print "Running in local mode.\n\n";	# in local mode, without the use of the object server

	foreach (<*.pm>) {			# scan this directory and force a 'use' of each ".pm"
		s/\.pm$//;			# file found (without the .pm suffix) so that the
		eval "use $_";			# classes are found and used locally instead
	}
} else {					# otherwise lets do everything via the remote
	print "Using remote server.\n\n";	# object server

	use SOAP::Lite
	+autodispatch	=>
		uri		=> 'http://wecan.com/',
		proxy		=> "tcp://$remote_host:$remote_port",	# object server via TCP service
		on_fault	=> sub {
					my($soap, $res) = @_;
					die ref $res ? $res->faultdetail : $soap->transport->status, "\n";
					};
}

Final Client (Part 2)

if ($local) {
	print "Running in local mode.\n\n";	# in local mode, without the use of the object server

	foreach (<*.pm>) {			# scan this directory and force a 'use' of each ".pm"
		s/\.pm$//;			# file found (without the .pm suffix) so that the
		eval "use $_";			# classes are found and used locally instead
	}
} else {					# otherwise lets do everything via the remote
	print "Using remote server.\n\n";	# object server

	use SOAP::Lite
	+autodispatch	=>
		uri		=> 'http://wecan.com/',
		proxy		=> "tcp://$remote_host:$remote_port",	# object server via TCP service
		on_fault	=> sub {
					my($soap, $res) = @_;
					die ref $res ? $res->faultdetail : $soap->transport->status, "\n";
					};
}

Note: Make a local/remote switch to allow local debugging.

Final Client (Part 3)

my $child1 = Child->new('Fulko');
$child1->set_age(44);

#print "member name: ", $child1->get_member_name(), "\n";
#print "member ref:  ", $child1->get_member_ref(), "\n";

#print "orig ref:  ", $child1->get_member_ref(), "\n";
my @list = Child::dump_obj_list();
print "list: ", join(', ', @list), "\n";

print "spot 1\n";
print "dump by explicit ref($child1):\n", $child1->dump_by_ref(0), "\n";
print "spot 2\n";

my $ref = Child::get_ref_by_member_ref($child1->get_member_name());
print "dumping by retrieved ref($ref):\n", $ref->dump_by_ref(0), "\n";

my $str = "$list[0]";
print "dumping by reference string($str):\n", Child::dump_by_member_ref_str($str, 0), "\n";

Final Client (Part 4)

my $time = scalar localtime;
$child1->set_member_name($time);
$ref = Child::get_ref_by_member_name($time);
print "dumping by retrieved name($ref):\n", $ref->dump_by_ref(0), "\n";

my $child2 = Child->new('Frank');
$child2->set_name('Franks new name');
#$child2->stooith();

print "object = $child1\n";
print "Should be 'fulko': " . $child1->get_name() . "\n";
print "Count: ", Child::get_count(), "\n";

$child1->set_name("Bill");
print "Should be 'Bill': " . $child1->get_name() . "\n";

print $child1->dump_by_ref(0), "\n";
$child1 = undef;
print "list: ", join(', ', Child::dump_obj_list()), "\n";

Final Client (Part 5)

my $horse = Horse->new('Ed');
my $horse2 = Horse->new('MrEd');
$horse->set_name("Eds new name");
print $horse2->dump_by_ref(0), "\n";
print "Horse count: ", Horse::get_count(), "\n";
$horse2->stooith();

print "$horse2\n";
print "Child count: ", Child::get_count(), "\n";
print "Horse count(2): ", Horse::get_count(), "\n";

print "Child: ", Child::dump_obj_list(), "\n";
print "Horses: ", Horse::dump_obj_list(), "\n";

Child.pm

package Child;
use warnings;
use PersistObj;
our @ISA = qw(PersistObj);

sub new {
	my $class	= $_[0];
	my $hash	= {one => 1, two => 2};
	my @ary		= [1,2,3];
	my @ary2	= [4,5,6];
    	my $obj		= {
        	_name		=> $_[1],
		_age		=> '',
		_hash		=> $hash,
		_array		=> @ary,
		_array2		=> @ary2,
    	};
    	bless $obj, $class;
	$obj->add_hash();	# record this instance
    	return $obj;
}

1;

Child.pm

package Child;
use warnings;
use PersistObj;
our @ISA = qw(PersistObj);

sub new {
	my $class	= $_[0];
	my $hash	= {one => 1, two => 2};
	my @ary		= [1,2,3];
	my @ary2	= [4,5,6];
    	my $obj		= {
        	_name		=> $_[1],
		_age		=> '',
		_hash		=> $hash,
		_array		=> @ary,
		_array2		=> @ary2,
    	};
    	bless $obj, $class;
	$obj->add_hash();	# record this instance
    	return $obj;
}

1;

Note: Change to PersistObj inheritance.

continued...

Child.pm

package Child;
use warnings;
use PersistObj;
our @ISA = qw(PersistObj);

sub new {
	my $class	= $_[0];
	my $hash	= {one => 1, two => 2};
	my @ary		= [1,2,3];
	my @ary2	= [4,5,6];
    	my $obj		= {
        	_name		=> $_[1],
		_age		=> '',
		_hash		=> $hash,
		_array		=> @ary,
		_array2		=> @ary2,
    	};
    	bless $obj, $class;
	$obj->add_hash();	# record this instance
    	return $obj;
}

1;

Note: Change to PersistObj inheritance.

Note: add_hash() is added to enable remote persistance.

Final Version of Magic

PersistObj.pm

package PersistObj;
use strict;
use warnings;
use Carp;
use vars '$AUTOLOAD';

my %_objectList = ();	# the list of persistant objects
my $debug = 0;		# enables object construction/destruction tracing
my $indent = 0;		# indent level for dumping
my $prefix;		# the prefix string used for indentation

# All classes that inherit from 'PersistObj' will automatically get the
# following two (reserved) attributes which are used for internal navigation
#
#	_member_ref	A place where the 'real' internal reference is saved
#	_member_name	A place where you can 'name' the object.
#			If you don't go the extent of naming the object,
#			its name will automatically be the reference

PersistObj.pm

sub dump_obj_list	{
	my ($implicit_class, $explicit_class) = @_;
	my $class = $explicit_class ? $explicit_class : $implicit_class;	# select the explicit if given
	my @list;
	foreach (keys (%_objectList)) {
		if (/^$class=/) {
			my $mem_name = ${$_objectList{$_}}->{_member_name};
			$mem_name = $mem_name ? $mem_name : $_;		# use the member's name if it exists
			push @list, $mem_name;				# record either the name or the reference
		}
	}
	@list;
}

PersistObj.pm

sub dump_class_list	{
	my %class_list = ();
	my @list;
	foreach (keys (%_objectList)) {
		my ($class) = /^(.*)=/;
		$class_list{$class} = 1;
	}
	foreach (sort keys %class_list) {
		push @list, $_;
	}
	@list;
}

PersistObj.pm

sub get_ref_by_member_ref {
	my ($class, $obj) = @_;

	#print "looking for: $$obj\n";
	if (exists $_objectList{$obj}) {
		#print "found it\n";
		return ${$_objectList{$obj}};
	}
}

PersistObj.pm

sub get_ref_by_member_name {
	my ($class, $name) = @_;

	#print "looking for: $name\n";
	foreach (keys (%_objectList)) {
		my $obj = ${$_objectList{$_}};
		#print "comparing against:$obj->{_member_name}\n";
		if (	(${$_objectList{$obj}}->{_member_name} eq $name) ||	# if the name or the reference
			(${$_objectList{$obj}}->{_member_ref} eq $name)) {	# matches, include it in the list
			#print "found it\n";
			return ${$_objectList{$obj}};
		}
	}
}

PersistObj.pm

sub dump_by_member_ref_str {
	my ($class, $obj, $html) = @_;
	#print "dump_by_member_ref_str($obj)\n";
	if (exists $_objectList{$obj}) {
		#print "found: $obj\nvalue: $_objectList{$obj}\n";
		return ${$_objectList{$obj}}->dump_by_ref($html);
	}
}

sub dump_by_ref {
	my ($obj, $html) = @_;
	#print "dump_by_ref($obj)\n";
	my $str = '';
	my ($class, $name) = ($obj =~ /(.*)=(.*)/);
	$name = $obj->{_member_name} ? $obj->{_member_name} : $name;
	if ($html) {
		$str .=<<EOF
<TABLE BORDER=0>
<TR><TD>
EOF
	} else {
		$str .= "Class:  $class\nObject: $name\n";
	}
	$str .= dump_hash($html, $obj);
	$str .= "</TD></TR></TABLE>\n" if ($html);
	return $str;
}

PersistObj.pm

sub dump_array {
	my ($html, @obj) = @_;
	#print "dump_array($html, @obj)\n";
	my ($str);
	$prefix = '  ' x ++$indent;

	$str = "\n$prefix<TABLE BORDER=1 WIDTH=100%>\n" if ($html);

	foreach (@obj) {
		$str .= "$prefix<TR><TD>\n" if ($html);
		if	(ref $_ eq 'ARRAY')	{ $str .= dump_array($html, @$_);	}
		elsif	(ref $_ eq 'HASH')	{ $str .= dump_hash($html, $_);		}
		elsif	(ref $_ eq 'CODE')	{ $str .= dump_code($html, $_);		}
		else				{ $str .= dump_scalar($html, $_);	}
		$str .= "$prefix</TD></TR>\n" if ($html);
	}
	$str .= "$prefix</TABLE>\n" if ($html);
	$prefix = '  ' x --$indent;
	return $str;
}

PersistObj.pm

sub dump_hash {
	my ($html, $obj) = @_;
	#print "dump_hash($html, $obj)\n";
	my ($str);
	$prefix = '  ' x ++$indent;

	$str = "\n$prefix<TABLE BORDER=1 WIDTH=100%>\n" if ($html);
	foreach my $key (sort keys %$obj) {		# print the object in lexographical order
		my $val = $$obj{$key};
		#next if ($key eq '_member_name');	# ignore the object's name
		#next if ($key eq '_member_ref');	# ignore the object's reference
		$str .= '  ' x $indent;

		if ($html)	{ $str .= "<TR><TH ALIGN=LEFT VALIGN=TOP>$key</TH><TD VALIGN=TOP>";	}
		else		{ $str .= "$key\n";													}

		if	(ref $val eq 'ARRAY')	{ $str .= dump_array($html, @$val);	}
		elsif	(ref $val eq 'HASH')	{ $str .= dump_hash($html, $val);	}
		elsif	(ref $val eq 'CODE')	{ $str .= dump_code($html, $val);	}
		else				{ $str .= dump_scalar($html, $val);	}

		$str .= "$prefix</TD></TR>\n" if ($html);
	}
	$str .= "$prefix</TABLE>\n" if ($html);
	$prefix = '  ' x --$indent;
	return $str;
}

PersistObj.pm

sub dump_scalar {
	my ($html, $scalar) = @_;
	my $str;
	$prefix = '  ' x ++$indent;
	$scalar = '' unless defined($scalar);				# make sure the scalar contains something
	if ($html)	{ $str = "$prefix$scalar<br>";		}
	else		{ $str = "$prefix(scalar): $scalar\n";	}
	$prefix = '  ' x --$indent;
	return $str;
}

sub dump_code {
	my ($html, $coderef) = @_;
	my $str;
	$prefix = '  ' x ++$indent;
	if ($html)	{ $str = "$prefix$coderef";		}
	else		{ $str = "$prefix(code): $coderef\n";	}
	$prefix = '  ' x --$indent;
	return $str;
}

PersistObj.pm

sub get_count {
	my $count = 0;
	my ($class) = ($_[0] =~ /(.*)=/);	# extract the class name from an object reference (if given)
	$class = $_[0] unless $class;		# or use the class name
	foreach (keys (%_objectList)) {
		$count++ if (/^$class=/);	# count up the entries with that class
	}
	$count;
}

PersistObj.pm

sub get_count {
	my $count = 0;
	my ($class) = ($_[0] =~ /(.*)=/);	# extract the class name from an object reference (if given)
	$class = $_[0] unless $class;		# or use the class name
	foreach (keys (%_objectList)) {
		$count++ if (/^$class=/);	# count up the entries with that class
	}
	$count;
}

Note: ... seems like it could be a useful method, and besides we had it before, for debugging.

PersistObj.pm

sub add_hash {
	print "adding $_[0]\n" if ($debug);
	$_[0]->{_member_ref}	= "$_[0]";	# record the strigified version of the objects reference
	$_[0]->{_member_name}	= "$_[0]";	# as the reference tag, and its default name
	$_objectList{$_[0]}	= \$_[0];	# record this instance in the class's object list
}

sub del_hash {
	delete $_objectList{$_[0]};		# remove all records of this object
}

PersistObj.pm

sub add_hash {
	print "adding $_[0]\n" if ($debug);
	$_[0]->{_member_ref}	= "$_[0]";	# record the strigified version of the objects reference
	$_[0]->{_member_name}	= "$_[0]";	# as the reference tag, and its default name
	$_objectList{$_[0]}	= \$_[0];	# record this instance in the class's object list
}

sub del_hash {
	delete $_objectList{$_[0]};		# remove all records of this object
}

Note: We discriminate between and internal identifier and the programmer's domain specific instance identifier.

PersistObj.pm

sub stooith {
	print "stooith($_[0])\n" if ($debug);
	$_[0]->del_hash();			# remove him from the list
	$_[0] = undef;				# and remove the last reference
}

PersistObj.pm

	# this routine gets called by soap::lite when it tries to auto garbage collect
	# since we don't want soap to garbage collect, we prevent objects on our
	# persistant list from dissapearing.  Client applications must use stooith()
	# to explicitly destroy them on the server.

sub garbage_collector {
	my (	$number_of_objects_of_this_class,		# if you want to implement cache
		$current_time,
		$object,
		$type,						# ref $object (class name)
		$creation_time,					# cannot be undef
		$last_access_time,				# can be undef if not accessed
		) = @_;
	print "garbage_collector(", join(", ", @_), ")  -->" if ($debug);
	if (exists ($_objectList{$object})) {
		print "left him around.\n" if ($debug);
		0;						# 0 = don't destroy, leave it persistent
	} else {
		print "destroyed it.\n" if ($debug);
		delete $_objectList{$object};			# forget he ever existed
		$object = undef;				# blow him away
		1;						# 1 = garbage collect it
	}
}

PersistObj.pm

sub AUTOLOAD {
	no strict "refs";

	my ($self, $newval) = @_;

	return if $AUTOLOAD =~ /::DESTROY$/;

	if ($AUTOLOAD =~ /.*::get(_\w+)/) {
		my $attr_name = $1;
		*{$AUTOLOAD} = sub {return $_[0]->{$attr_name} };
		return $self->{$attr_name};
	}

	if ($AUTOLOAD =~ /.*::set(_\w+)/) {
		my $attr_name = $1;
		*{$AUTOLOAD} = sub { $_[0]->{$attr_name} = $_[1]; return; };
		$self->{$1} = $newval;
	return;
	}
croak "No such method: $AUTOLOAD";
}

1;

Object Browser

• Now we have:

  • persistent object server

Object Browser

• Now we have:

  • persistent object server

  • clients that can be programmed as if they are local

Object Browser

• Now we have:

  • persistent object server

  • clients that can be programmed as if they are local

  • namable objects

Object Browser

• Now we have:

  • persistent object server

  • clients that can be programmed as if they are local

  • namable objects

     

• We need the browser

dump.pl (Part 1)

#!/root/fulko/bin/perl

use strict;
#use warnings;
no warnings "deprecated";	# SOAP::Lite's autodispatch depends on that "accidental feature"

package main;

use CGI;

my $hilit = '0xffff80';
my $normal = 'white';
my $refreshTmo = 10;			# num of seconds to wait before auto-refreshing

$refreshTmo = $refreshTmo * 1000;	# javascript wants them in milliseconds
our ($remote_host, $remote_port);
BEGIN {
	$remote_host = 'localhost';
	$remote_port = '2000';
}

dump.pl (Part 1)

#!/root/fulko/bin/perl

use strict;
#use warnings;
no warnings "deprecated";	# SOAP::Lite's autodispatch depends on that "accidental feature"

package main;

use CGI;

my $hilit = '0xffff80';
my $normal = 'white';
my $refreshTmo = 10;			# num of seconds to wait before auto-refreshing

$refreshTmo = $refreshTmo * 1000;	# javascript wants them in milliseconds
our ($remote_host, $remote_port);
BEGIN {
	$remote_host = 'localhost';
	$remote_port = '2000';
}

Note: Just another client... with some web stuff.

dump.pl (Part 2)

use SOAP::Lite
#+trace => all,			# uncoment this for traceability
+autodispatch	=>
	uri		=> 'http://wecan.com/',
	proxy		=> "tcp://$remote_host:$remote_port",	# object server via TCP service
	on_fault	=> sub {
				my($soap, $res) = @_;
				die ref $res ? $res->faultdetail : $soap->transport->status, "\n";
				};

eval { @main::class_list = PersistObj::dump_class_list(); };
$main::server_avail = $@;

dump.pl (Part 2)

use SOAP::Lite
#+trace => all,			# uncoment this for traceability
+autodispatch	=>
	uri		=> 'http://wecan.com/',
	proxy		=> "tcp://$remote_host:$remote_port",	# object server via TCP service
	on_fault	=> sub {
				my($soap, $res) = @_;
				die ref $res ? $res->faultdetail : $soap->transport->status, "\n";
				};

eval { @main::class_list = PersistObj::dump_class_list(); };
$main::server_avail = $@;

Note: I can't remember why this is eval'ed. :-(

dump.pl (Part 3)

sub class_list {			# the class list was actually fetched earlier
	my ($class) = @_;

	my ($color);
	print "<CENTER><B>Classes</B></CENTER><BR>";
	print "<TABLE CELLPADDING=0 CELLSPACING=0 BORDER=0>\n";
	foreach (@main::class_list) {
		if ($_ eq $class)	{ $color = $hilit;	}
		else			{ $color = $normal;	}
		print "<TR BGCOLOR='$color'><TD><A HREF onClick=\"return setClass('$_');\">$_</A></TD></TR>\n";
	}
	print "</TABLE>\n";
}

dump.pl (Part 4)

sub member_list {
	my ($class, $member) = @_;
	my ($color, @list);
	print "<CENTER><B>Members of $class</B></CENTER>\n";
	print "<TABLE CELLPADDING=0 CELLSPACING=0 BORDER=0>\n";

	eval { @list = PersistObj::dump_obj_list($class) };
	my (%by_name, %by_ref);
	foreach (@list) {
		my ($ref) = /^.*=HASH\((.*)\)/;
		if ($ref)	{ $by_ref{$_} = $_;	}	# key: (reference)	name, value = reference
		else		{ $by_name{$_} = $_;	}	# key: (human)		name, value = reference
		}
	foreach (sort keys %by_ref) {
		if ($_ eq $member)	{ $color = $hilit;	}
		else			{ $color = $normal;	}
		print <<EOF;
<TR BGCOLOR='$color'><TD><A HREF onClick=\"return setMem('$by_ref{$_}');\">$_</A></TD></TR>
EOF
	}
	foreach (sort keys %by_name) {
		if ($_ eq $member)	{ $color = $hilit;	}
		else			{ $color = $normal;	}
		print <<EOF;
<TR BGCOLOR='$color'><TD><A HREF onClick=\"return setMem('$_');\">$by_name{$_}</A></TD></TR>
EOF
	}
	print "</TABLE>\n";
}

dump.pl (Part 5)

sub object_browser {
	my ($class, $object) = @_;

	my ($obj_ref, $str);
	eval { $obj_ref = PersistObj::get_ref_by_member_name($object) };
	if ($obj_ref) {
		$str = $obj_ref->dump_by_ref(1);
		$str =~ s/&lt;/</g;
		print "$str\n";
	}
}

dump.pl (Part 6)

sub error_no {
	my $type = shift;

	print <<EOF;
<TABLE WIDTH=100% HEIGHT=100% BORDER=0>
	<TR><TH VALIGN=CENTER>No $type selected</TH></TR>
</TABLE>
EOF
}

dump.pl (Part 7)

my $query = new CGI;
print $query->header();
#print $query->Dump;

my $class = $query->param('class_var');
my $member = $query->param('member_var');

dump.pl (Part 8)

print <<EOF;
<HTML>
<HEAD>
<TITLE>CMT Class Browser</TITLE>
</HEAD>
<style type="text/css">
<!--
a {
	color:Blue;
	text-decoration:none;
}
a:link		{color: Blue;}
a:visited	{color: Blue;}
a:hover		{color: Red;}
-->
</style>

dump.pl (Part 9)

<BODY>
<SCRIPT LANGUAGE="Javascript">
<!--

function setClass (c) {
	document.f1.class_var.value = c;
	document.f1.member_var.value = '';	// erase the member when we change classes
	document.f1.submit();
	return false;
}

function setMem (m) {
	document.f1.member_var.value = m;
	document.f1.submit();
	return false;
}

setTimeout("document.f1.submit()", 10000);	// auto-refresh the screen every 10 seconds

// -->
</SCRIPT>

dump.pl (Part 10)

<FORM METHOD=POST NAME="f1" ACTION="/tiger/dump.pl">
<INPUT TYPE="hidden" NAME="class_var" VALUE="$class">
<INPUT TYPE="hidden" NAME="member_var" VALUE="$member">
<TABLE BORDER=1 CELLPADDING=5 WIDTH=100% HEIGHT=100%>
	<TR><TD ROWSPAN=2 VALIGN=TOP>
		<CENTER><INPUT TYPE="submit" VALUE="Refresh"></CENTER>
EOF

if ($main::server_avail) {
	print <<EOF;
		<TABLE WIDTH=100% HEIGHT=100%>
			<TR><TH VALIGN=CENTER>No object server found</TH></TR>
		</TABLE>
	</TD></TR>
</TABLE>
<SCRIPT LANGUAGE="Javascript">
<!--
	document.f1.member_var.value = '';	// forget what we were looking at
	document.f1.member_class.value = '';	// if the server goes away
// -->
</SCRIPT>
</FORM>
</HTML>
EOF
	exit;
}

dump.pl (Part 11)

class_list($class);

print <<EOF;
</TD>
<TD VALIGN=TOP WIDTH=100%>
EOF

if ($class)	{ member_list($class, $member);	}
else		{ error_no('class');		}

print <<EOF;
</TD></TR>
<TR><TD VALIGN=TOP HEIGHT=100%>
EOF

if ($class && $member)	{ object_browser($class, $member);	}
else			{ error_no('instance');			}

print <<EOF;
</TD></TR>
</TABLE>
</FORM>
</BODY></HTML>
EOF

Demo

• /var/www/html/tiger/server

• /var/www/html/tiger/client

• http://localhost/tiger/dump.pl

Review

Futures - Browser

• add/delete/copy objects

• alter attribute values

• follow references

• search for classes & instances (when the list is big)

• make the object browser prettier

• mod_perl'ed object browser

• auto-refresh the browser when:

  • instances are created or destroyed

  • attributes are modified

Futures - PersistObj.pm

• object flushing/restoring cached objects to offline storage

Downsides

• SOAP is slow

• autodispatch on Perl 5.8.0 doesn't work (mentioned in the book)

References

• SOAP::Lite

  www.soaplite.com

• Programming Web Services with SOAP [Writing SOAP Web Services]

  http://www.oreilly.com/catalog/progwebsoap/

• SOAP::Lite Mailing List

  soaplite-subscribe@yahoogroups.com

• SNAP - EMSoftware Solutions, Inc (a.k.a. Template Software)

  www.http://www.EMSoftwareInc.com.com