--- /dev/null
+#
+# module to manage connection lists & data
+#
+
+package DXConnect;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+%connects = undef;
+
+# create a new connection object [$obj = Connect->new($call, $msg_conn_obj, $user_obj)]
+sub new
+{
+ my ($pkg, $call, $conn, $user) = @_;
+ my $self = {};
+
+ die "trying to create a duplicate Connect for call $call\n" if $connects{$call};
+ $self->{call} = $call;
+ $self->{conn} = $conn;
+ $self->{user} = $user;
+ $self->{t} = time;
+ $self->{state} = 0;
+ bless $self, $pkg;
+ return $connects{$call} = $self;
+}
+
+# obtain a connection object by callsign [$obj = Connect->get($call)]
+sub get
+{
+ my ($pkg, $call) = @_;
+ return $connect{$call};
+}
+
+# obtain all the connection objects
+sub get_all
+{
+ my ($pkg) = @_;
+ return values(%connects);
+}
+
+# obtain a connection object by searching for its connection reference
+sub get_by_cnum
+{
+ my ($pkg, $conn) = @_;
+ my $self;
+
+ foreach $self (values(%connects)) {
+ return $self if ($self->{conn} == $conn);
+ }
+ return undef;
+}
+
+# get rid of a connection object [$obj->del()]
+sub del
+{
+ my $self = shift;
+ delete $connects{$self->{call}};
+}
+
+1;
+__END__;
--- /dev/null
+#
+# DX cluster user routines
+#
+
+package DXUser;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+use MLDBM;
+use Fcntl;
+
+%u = undef;
+$dbm = undef;
+$filename = undef;
+
+#
+# initialise the system
+#
+sub init
+{
+ my ($pkg, $fn) = @_;
+
+ die "need a filename in User\n" if !$fn;
+ $dbm = tie %u, MLDBM, $fn, O_CREAT|O_RDWR, 0666 or die "can't open user file: $fn ($!)\n";
+ $filename = $fn;
+}
+
+#
+# close the system
+#
+
+sub finish
+{
+ $dbm = undef;
+ untie %u;
+}
+
+#
+# new - create a new user
+#
+
+sub new
+{
+ my ($call) = @_;
+ die "can't create existing call $call in User\n!" if $u{$call};
+
+ my $self = {};
+ $self->{call} = $call;
+ bless $self;
+ $u{call} = $self;
+}
+
+#
+# get - get an existing user
+#
+
+sub get
+{
+ my ($call) = @_;
+ return $u{$call};
+}
+
+#
+# put - put a user
+#
+
+sub put
+{
+ my $self = shift;
+ my $call = $self->{call};
+ $u{$call} = $self;
+}
+
+#
+# del - delete a user
+#
+
+sub del
+{
+ my $self = shift;
+ my $call = $self->{call};
+ delete $u{$call};
+}
+
+#
+# close - close down a user
+#
+
+sub close
+{
+ my $self = shift;
+ $self->{lastin} = time;
+ $self->put();
+}
+
+1;
+__END__
--- /dev/null
+#
+# various utilities which are exported globally
+#
+
+package DXUtil;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(atime
+ );
+
+@month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+
+sub atime
+{
+ my ($sec,$min,$hour,$mday,$mon,$year) = gmtime(time);
+ $year += 1900;
+ my $buf = sprintf "%02d%s%04d\@%02d:%02d:%02d", $mday, $month[$mon], $year, $hour, $min, $sec;
+ return $buf;
+}
+
+
+
--- /dev/null
+#
+# The system variables - those indicated will need to be changed to suit your
+# circumstances (and callsign)
+#
+
+package main;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+@EXPORT_OK = qw($mycall $myname $mynormalcall $mylatitude $mylongtitude $mylocator
+ $myqth $myemail $myprot
+ $clusterport $clusteraddr $debugfn
+ $def_hopcount $root $data $system $cmd
+ $userfn
+ );
+
+
+# this really does need to change for your system!!!!
+$mycall = "GB7TLH";
+
+# your name
+$myname = "Dirk";
+
+# Your 'normal' callsign
+$mynormalcall = "G1TLH";
+
+# Your latitude (+)ve = North (-)ve = South in degrees and decimal degrees
+$mylatitude = +52.68584579;
+
+# Your Longtitude (+)ve = East, (-)ve = West in degrees and decimal degrees
+$mylongtitude = +0.94518260;
+
+# Your locator (yes I know I can calculate it - eventually)
+$mylocator = "JO02LQ";
+
+# Your QTH (roughly)
+$myqth = "East Dereham, Norfolk";
+
+# Your e-mail address
+$myemail = "djk@tobit.co.uk";
+
+# the tcp address of the cluster and so does this !!!
+$clusteraddr = "dirk1.tobit.co.uk";
+
+# the port number of the cluster (just leave this, unless it REALLY matters to you)
+$clusterport = 27754;
+
+# cluster debug file
+$debugfn = "/tmp/debug_cluster";
+
+# the version of DX cluster (tm) software I am masquerading as
+$myprot = "5447";
+
+# default hopcount to use - note this will override any incoming hop counts, if they are greater
+$def_hopcount = 7;
+
+# root of directory tree for this system
+$root = "/spider";
+
+# data files live in
+$data = "$root/data";
+
+# system files live in
+$system = "$root/sys";
+
+# command files live in
+$cmd = "$root/cmd";
+
+# where the user data lives
+$userfn = "$data/users";
--- /dev/null
+#
+# This has been taken from the 'Advanced Perl Programming' book by Sriram Srinivasan
+#
+# I am presuming that the code is distributed on the same basis as perl itself.
+#
+# I have modified it to suit my devious purposes (Dirk Koopman G1TLH)
+#
+package Msg;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+use strict;
+use IO::Select;
+use IO::Socket;
+use Carp;
+
+use vars qw (%rd_callbacks %wt_callbacks $rd_handles $wt_handles);
+
+%rd_callbacks = ();
+%wt_callbacks = ();
+$rd_handles = IO::Select->new();
+$wt_handles = IO::Select->new();
+my $blocking_supported = 0;
+
+BEGIN {
+ # Checks if blocking is supported
+ eval {
+ require POSIX; POSIX->import(qw (F_SETFL O_NONBLOCK EAGAIN));
+ };
+ $blocking_supported = 1 unless $@;
+}
+
+#-----------------------------------------------------------------
+# Send side routines
+sub connect {
+ my ($pkg, $to_host, $to_port,$rcvd_notification_proc) = @_;
+
+ # Create a new internet socket
+
+ my $sock = IO::Socket::INET->new (
+ PeerAddr => $to_host,
+ PeerPort => $to_port,
+ Proto => 'tcp',
+ Reuse => 1);
+
+ return undef unless $sock;
+
+ # Create a connection end-point object
+ my $conn = {
+ sock => $sock,
+ rcvd_notification_proc => $rcvd_notification_proc,
+ };
+
+ if ($rcvd_notification_proc) {
+ my $callback = sub {_rcv($conn, 0)};
+ set_event_handler ($sock, "read" => $callback);
+ }
+ return bless $conn, $pkg;
+}
+
+sub disconnect {
+ my $conn = shift;
+ my $sock = delete $conn->{sock};
+ return unless defined($sock);
+ set_event_handler ($sock, "read" => undef, "write" => undef);
+ close($sock);
+}
+
+sub send_now {
+ my ($conn, $msg) = @_;
+ _enqueue ($conn, $msg);
+ $conn->_send (1); # 1 ==> flush
+}
+
+sub send_later {
+ my ($conn, $msg) = @_;
+ _enqueue($conn, $msg);
+ my $sock = $conn->{sock};
+ return unless defined($sock);
+ set_event_handler ($sock, "write" => sub {$conn->_send(0)});
+}
+
+sub _enqueue {
+ my ($conn, $msg) = @_;
+ # prepend length (encoded as network long)
+ my $len = length($msg);
+ $msg = pack ('N', $len) . $msg;
+ push (@{$conn->{queue}}, $msg);
+}
+
+sub _send {
+ my ($conn, $flush) = @_;
+ my $sock = $conn->{sock};
+ return unless defined($sock);
+ my ($rq) = $conn->{queue};
+
+ # If $flush is set, set the socket to blocking, and send all
+ # messages in the queue - return only if there's an error
+ # If $flush is 0 (deferred mode) make the socket non-blocking, and
+ # return to the event loop only after every message, or if it
+ # is likely to block in the middle of a message.
+
+ $flush ? $conn->set_blocking() : $conn->set_non_blocking();
+ my $offset = (exists $conn->{send_offset}) ? $conn->{send_offset} : 0;
+
+ while (@$rq) {
+ my $msg = $rq->[0];
+ my $bytes_to_write = length($msg) - $offset;
+ my $bytes_written = 0;
+ while ($bytes_to_write) {
+ $bytes_written = syswrite ($sock, $msg,
+ $bytes_to_write, $offset);
+ if (!defined($bytes_written)) {
+ if (_err_will_block($!)) {
+ # Should happen only in deferred mode. Record how
+ # much we have already sent.
+ $conn->{send_offset} = $offset;
+ # Event handler should already be set, so we will
+ # be called back eventually, and will resume sending
+ return 1;
+ } else { # Uh, oh
+ $conn->handle_send_err($!);
+ return 0; # fail. Message remains in queue ..
+ }
+ }
+ $offset += $bytes_written;
+ $bytes_to_write -= $bytes_written;
+ }
+ delete $conn->{send_offset};
+ $offset = 0;
+ shift @$rq;
+ last unless $flush; # Go back to select and wait
+ # for it to fire again.
+ }
+ # Call me back if queue has not been drained.
+ if (@$rq) {
+ set_event_handler ($sock, "write" => sub {$conn->_send(0)});
+ } else {
+ set_event_handler ($sock, "write" => undef);
+ }
+ 1; # Success
+}
+
+sub _err_will_block {
+ if ($blocking_supported) {
+ return ($_[0] == EAGAIN());
+ }
+ return 0;
+}
+sub set_non_blocking { # $conn->set_blocking
+ if ($blocking_supported) {
+ # preserve other fcntl flags
+ my $flags = fcntl ($_[0], F_GETFL(), 0);
+ fcntl ($_[0], F_SETFL(), $flags | O_NONBLOCK());
+ }
+}
+sub set_blocking {
+ if ($blocking_supported) {
+ my $flags = fcntl ($_[0], F_GETFL(), 0);
+ $flags &= ~O_NONBLOCK(); # Clear blocking, but preserve other flags
+ fcntl ($_[0], F_SETFL(), $flags);
+ }
+}
+sub handle_send_err {
+ # For more meaningful handling of send errors, subclass Msg and
+ # rebless $conn.
+ my ($conn, $err_msg) = @_;
+ warn "Error while sending: $err_msg \n";
+ set_event_handler ($conn->{sock}, "write" => undef);
+}
+
+#-----------------------------------------------------------------
+# Receive side routines
+
+my ($g_login_proc,$g_pkg);
+my $main_socket = 0;
+sub new_server {
+ @_ == 4 || die "Msg->new_server (myhost, myport, login_proc)\n";
+ my ($pkg, $my_host, $my_port, $login_proc) = @_;
+
+ $main_socket = IO::Socket::INET->new (
+ LocalAddr => $my_host,
+ LocalPort => $my_port,
+ Listen => 5,
+ Proto => 'tcp',
+ Reuse => 1);
+ die "Could not create socket: $! \n" unless $main_socket;
+ set_event_handler ($main_socket, "read" => \&_new_client);
+ $g_login_proc = $login_proc; $g_pkg = $pkg;
+}
+
+sub rcv_now {
+ my ($conn) = @_;
+ my ($msg, $err) = _rcv ($conn, 1); # 1 ==> rcv now
+ return wantarray ? ($msg, $err) : $msg;
+}
+
+sub _rcv { # Complement to _send
+ my ($conn, $rcv_now) = @_; # $rcv_now complement of $flush
+ # Find out how much has already been received, if at all
+ my ($msg, $offset, $bytes_to_read, $bytes_read);
+ my $sock = $conn->{sock};
+ return unless defined($sock);
+ if (exists $conn->{msg}) {
+ $msg = $conn->{msg};
+ $offset = length($msg) - 1; # sysread appends to it.
+ $bytes_to_read = $conn->{bytes_to_read};
+ delete $conn->{'msg'}; # have made a copy
+ } else {
+ # The typical case ...
+ $msg = ""; # Otherwise -w complains
+ $offset = 0 ;
+ $bytes_to_read = 0 ; # Will get set soon
+ }
+ # We want to read the message length in blocking mode. Quite
+ # unlikely that we'll get blocked too long reading 4 bytes
+ if (!$bytes_to_read) { # Get new length
+ my $buf;
+ $conn->set_blocking();
+ $bytes_read = sysread($sock, $buf, 4);
+ if ($! || ($bytes_read != 4)) {
+ goto FINISH;
+ }
+ $bytes_to_read = unpack ('N', $buf);
+ }
+ $conn->set_non_blocking() unless $rcv_now;
+ while ($bytes_to_read) {
+ $bytes_read = sysread ($sock, $msg, $bytes_to_read, $offset);
+ if (defined ($bytes_read)) {
+ if ($bytes_read == 0) {
+ last;
+ }
+ $bytes_to_read -= $bytes_read;
+ $offset += $bytes_read;
+ } else {
+ if (_err_will_block($!)) {
+ # Should come here only in non-blocking mode
+ $conn->{msg} = $msg;
+ $conn->{bytes_to_read} = $bytes_to_read;
+ return ; # .. _rcv will be called later
+ # when socket is readable again
+ } else {
+ last;
+ }
+ }
+ }
+
+ FINISH:
+ if (length($msg) == 0) {
+ $conn->disconnect();
+ }
+ if ($rcv_now) {
+ return ($msg, $!);
+ } else {
+ &{$conn->{rcvd_notification_proc}}($conn, $msg, $!);
+ }
+}
+
+sub _new_client {
+ my $sock = $main_socket->accept();
+ my $conn = bless {
+ 'sock' => $sock,
+ 'state' => 'connected'
+ }, $g_pkg;
+ my $rcvd_notification_proc =
+ &$g_login_proc ($conn, $sock->peerhost(), $sock->peerport());
+ if ($rcvd_notification_proc) {
+ $conn->{rcvd_notification_proc} = $rcvd_notification_proc;
+ my $callback = sub {_rcv($conn,0)};
+ set_event_handler ($sock, "read" => $callback);
+ } else { # Login failed
+ $conn->disconnect();
+ }
+}
+
+#----------------------------------------------------
+# Event loop routines used by both client and server
+
+sub set_event_handler {
+ shift unless ref($_[0]); # shift if first arg is package name
+ my ($handle, %args) = @_;
+ my $callback;
+ if (exists $args{'write'}) {
+ $callback = $args{'write'};
+ if ($callback) {
+ $wt_callbacks{$handle} = $callback;
+ $wt_handles->add($handle);
+ } else {
+ delete $wt_callbacks{$handle};
+ $wt_handles->remove($handle);
+ }
+ }
+ if (exists $args{'read'}) {
+ $callback = $args{'read'};
+ if ($callback) {
+ $rd_callbacks{$handle} = $callback;
+ $rd_handles->add($handle);
+ } else {
+ delete $rd_callbacks{$handle};
+ $rd_handles->remove($handle);
+ }
+ }
+}
+
+sub event_loop {
+ my ($pkg, $loop_count, $timeout) = @_; # event_loop(1) to process events once
+ my ($conn, $r, $w, $rset, $wset);
+ while (1) {
+ # Quit the loop if no handles left to process
+ last unless ($rd_handles->count() || $wt_handles->count());
+ ($rset, $wset) =
+ IO::Select->select ($rd_handles, $wt_handles, undef, $timeout);
+ foreach $r (@$rset) {
+ &{$rd_callbacks{$r}} ($r) if exists $rd_callbacks{$r};
+ }
+ foreach $w (@$wset) {
+ &{$wt_callbacks{$w}}($w) if exists $wt_callbacks{$w};
+ }
+ if (defined($loop_count)) {
+ last unless --$loop_count;
+ }
+ }
+}
+
+1;
+
+__END__
+
--- /dev/null
+#!/usr/bin/perl
+#
+# A thing that implements dxcluster 'protocol'
+#
+# This is a perl module/program that sits on the end of a dxcluster
+# 'protocol' connection and deals with anything that might come along.
+#
+# this program is called by ax25d and gets raw ax25 text on its input
+#
+# Copyright (c) 1998 Dirk Koopman G1TLH
+#
+#
+
+use Msg;
+use DXVars;
+
+$mode = 1; # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent
+$call = ""; # the callsign being used
+@stdoutq = (); # the queue of stuff to send out to the user
+$conn = 0; # the connection object for the cluster
+$lastbit = ""; # the last bit of an incomplete input line
+
+# cease communications
+sub cease
+{
+ my $sendz = shift;
+ if (defined $conn && $sendz) {
+ $conn->send_now("Z$call|bye...\n");
+ }
+ exit(0);
+}
+
+# terminate program from signal
+sub sig_term
+{
+ cease(1);
+}
+
+# handle incoming messages
+sub rec_socket
+{
+ my ($con, $msg, $err) = @_;
+ if (defined $err && $err) {
+ cease(1);
+ }
+ if (defined $msg) {
+ my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)|(.*)$/;
+
+ if ($sort eq 'D') {
+ my $nl = ($mode == 1) ? "\r" : "\n";
+ $nl = "" if $mode == 0;
+ $line =~ s/\n/\r/o if $mode == 1;
+ print $line, $nl;
+ } elsif ($sort eq 'M') {
+ $mode = $line; # set new mode from cluster
+ } elsif ($sort eq 'Z') { # end, disconnect, go, away .....
+ cease(0);
+ }
+ }
+}
+
+sub rec_stdin
+{
+ my ($fh) = @_;
+ my $buf;
+ my @lines;
+ my $r;
+ my $first;
+ my $dangle = 0;
+
+ $r = sysread($fh, $buf, 1024);
+# print "sys: $r $buf";
+ if ($r > 0) {
+ if ($mode) {
+ $buf =~ s/\r/\n/o if $mode == 1;
+ $dangle = !($buf =~ /\n$/);
+ @lines = split /\n/, $buf;
+ if ($dangle) { # pull off any dangly bits
+ $buf = pop @lines;
+ } else {
+ $buf = "";
+ }
+ $first = shift @lines;
+ unshift @lines, ($lastbit . $first) if ($first);
+ foreach $first (@lines) {
+ $conn->send_now("D$call|$first");
+ }
+ $lastbit = $buf;
+ } else {
+ $conn->send_now("D$call|$buf");
+ }
+ } elsif ($r == 0) {
+ cease(1);
+ }
+}
+
+$call = uc $ARGV[0];
+die "client.pl <call> [<mode>]\r\n" if (!$call);
+$mode = $ARGV[1] if (@ARGV > 1);
+
+select STDOUT; $| = 1;
+
+$SIG{'INT'} = \&sig_term;
+$SIG{'TERM'} = \&sig_term;
+$SIG{'HUP'} = \&sig_term;
+
+$conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket);
+$conn->send_now("A$call|start");
+Msg->set_event_handler(\*STDIN, "read" => \&rec_stdin);
+Msg->event_loop();
+
--- /dev/null
+#!/usr/bin/perl
+#
+# A thing that implements dxcluster 'protocol'
+#
+# This is a perl module/program that sits on the end of a dxcluster
+# 'protocol' connection and deals with anything that might come along.
+#
+# this program is called by ax25d and gets raw ax25 text on its input
+#
+# Copyright (c) 1998 Dirk Koopman G1TLH
+#
+#
+
+use Msg;
+use DXVars;
+use DXUtil;
+use DXConnect;
+use DXUser;
+
+package main;
+
+@inqueue = undef; # the main input queue, an array of hashes
+
+# handle out going messages
+sub send_now
+{
+ my ($conn, $sort, $call, $line) = @_;
+
+ print DEBUG "$t > $sort $call $line\n" if defined DEBUG;
+ print "> $sort $call $line\n";
+ $conn->send_now("$sort$call|$line");
+}
+
+sub send_later
+{
+ my ($conn, $sort, $call, $line) = @_;
+
+ print DEBUG "$t > $sort $call $line\n" if defined DEBUG;
+ print "> $sort $call $line\n";
+ $conn->send_later("$sort$call|$line");
+}
+
+# handle disconnections
+sub disconnect
+{
+ my $dxconn = shift;
+ my ($user) = $dxconn->{user};
+ my ($conn) = $dxconn->{conn};
+ $user->close() if defined $user;
+ $conn->disconnect();
+ $dxconn->del();
+}
+
+# handle incoming messages
+sub rec
+{
+ my ($conn, $msg, $err) = @_;
+ my $dxconn = DXConnect->get_by_cnum($conn); # get the dxconnnect object for this message
+
+ if (defined $err && $err) {
+ disconnect($dxconn);
+ return;
+ }
+ if (defined $msg) {
+ my $self = bless {}, "inqueue";
+ $self->{dxconn} = $dxconn;
+ $self->{data} = $msg;
+ push @inqueue, $self;
+ }
+}
+
+sub login
+{
+ return \&rec;
+}
+
+# cease running this program, close down all the connections nicely
+sub cease
+{
+ my $dxconn;
+ foreach $dxconn (DXConnect->get_all()) {
+ disconnect($dxconn);
+ }
+}
+
+# this is where the input queue is dealt with and things are dispatched off to other parts of
+# the cluster
+sub process_inqueue
+{
+ my $self = shift @inqueue;
+ return if !$self;
+
+ my $data = $self->{data};
+ my $dxconn = $self->{dxconn};
+ my ($sort, $call, $line) = $data =~ /^(\w)(\S+)|(.*)$/;
+
+ # do the really sexy console interface bit! (Who is going to do the TK interface then?)
+ print DEBUG atime, " < $sort $call $line\n" if defined DEBUG;
+ print "< $sort $call $line\n";
+
+ # handle A records
+ if ($sort eq 'A') {
+ if ($dxconn) { # there should not be one of these, disconnect
+
+ }
+ my $user = DXUser->get($call); # see if we have one of these
+ }
+
+}
+
+#############################################################
+#
+# The start of the main line of code
+#
+#############################################################
+
+# open the debug file, set various FHs to be unbuffered
+open(DEBUG, ">>$debugfn") or die "can't open $debugfn($!)\n";
+select DEBUG; $| = 1;
+select STDOUT; $| = 1;
+
+# initialise User file system
+DXUser->init($userfn);
+
+# start listening for incoming messages/connects
+Msg->new_server("$clusteraddr", $clusterport, \&login);
+
+# prime some signals
+$SIG{'INT'} = \&cease;
+$SIG{'TERM'} = \&cease;
+$SIG{'HUP'} = 'IGNORE';
+
+# this, such as it is, is the main loop!
+for (;;) {
+ Msg->event_loop(1, 0.001);
+ process_inqueue();
+}
+
--- /dev/null
+
+#
+# testmsg.pl - Used for testing the Msg.pm module
+# Invoke as testmsg.pl {-client|-server}
+#
+use Msg;
+use strict;
+
+my $i = 0;
+sub rcvd_msg_from_server {
+ my ($conn, $msg, $err) = @_;
+ if (defined $msg) {
+ die "Strange... shouldn't really be coming here\n";
+ }
+}
+
+my $incoming_msg_count=0;
+
+sub rcvd_msg_from_client {
+ my ($conn, $msg, $err) = @_;
+ if (defined $msg) {
+ ++$i;
+ my $len = length ($msg);
+ print "$i ($len)\n";
+ }
+}
+
+sub login_proc {
+ # Unconditionally accept
+ \&rcvd_msg_from_client;
+}
+
+my $host = 'localhost';
+my $port = 8080;
+my $prog;
+foreach $prog (@ARGV) {
+ if ($prog eq '-server') {
+ Msg->new_server($host, $port, \&login_proc);
+ print "Server created. Waiting for events";
+ Msg->event_loop();
+ } elsif ($prog eq '-client') {
+ my $conn = Msg->connect($host, $port,
+ \&rcvd_msg_from_server);
+
+ die "Client could not connect to $host:$port\n" unless $conn;
+ print "Connection successful.\n";
+ my $i;
+ my $msg = " " x 10000;
+ for ($i = 0; $i < 100; $i++) {
+ print "Sending msg $i\n";
+ $conn->send_now($msg);
+ }
+ $conn->disconnect();
+ Msg->event_loop();
+ }
+}
+
--- /dev/null
+
+ /* persistent.c */
+#include <EXTERN.h>
+#include <perl.h>
+
+ /* 1 = clean out filename's symbol table after each request, 0 = don't */
+#ifndef DO_CLEAN
+# define DO_CLEAN 0
+#endif
+
+static PerlInterpreter *perl = NULL;
+
+int main(int argc, char **argv, char **env)
+{
+ char *embedding[] = { "", "persistent.pl"};
+ char *args[] = { "", DO_CLEAN, NULL };
+ char filename [1024];
+ int exitstatus = 0;
+
+ if ((perl = perl_alloc()) == NULL) {
+ fprintf(stderr, "no memory!");
+ exit(1);
+ }
+ perl_construct(perl);
+
+ exitstatus = perl_parse(perl, NULL, 2, embedding, NULL);
+
+ if(!exitstatus) {
+ exitstatus = perl_run(perl);
+
+ while(printf("Enter file name: ") && gets(filename)) {
+
+ /* call the subroutine, passing it the filename as an argument */
+ args[0] = filename;
+ perl_call_argv("Embed::Persistent::eval_file",
+ G_DISCARD | G_EVAL, args);
+
+ /* check $@ */
+ if(SvTRUE(GvSV(errgv)))
+ fprintf(stderr, "eval error: %s\n", SvPV(GvSV(errgv),na));
+ }
+ }
+
+ perl_destruct_level = 0;
+ perl_destruct(perl);
+ perl_free(perl);
+ exit(exitstatus);
+}
--- /dev/null
+package Embed::Persistent;
+#persistent.pl
+
+#require Devel::Symdump;
+use strict;
+use vars '%Cache';
+
+sub valid_package_name {
+ my($string) = @_;
+ $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
+#second pass only for words starting with a digit
+ $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
+
+#Dress it up as a real package name
+ $string =~ s|/|::|g;
+ return "Embed" . $string;
+}
+
+#borrowed from Safe.pm
+sub delete_package {
+ my $pkg = shift;
+ my ($stem, $leaf);
+
+ no strict 'refs';
+ $pkg = "main::$pkg\::"; # expand to full symbol table name
+ ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+
+ my $stem_symtab = *{$stem}{HASH };
+
+ delete $stem_symtab->{$leaf };
+ }
+
+sub eval_file {
+ my($filename, $delete) = @_;
+ my $package = valid_package_name($filename);
+ my $mtime = -M $filename;
+ if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
+#we have compiled this subroutine already,
+#it has not been updated on disk, nothing left to do
+ print STDERR "already compiled $package->handler\n";
+ } else {
+ local *FH;
+ open FH, $filename or die "open '$filename' $!";
+ local($/) = undef;
+ my $sub = <FH>;
+ close FH;
+
+#wrap the code into a subroutine inside our unique package
+ my $eval = qq{package $package; sub handler { $sub; }};
+ {
+#hide our variables within this block
+ my($filename,$mtime,$package,$sub);
+ eval $eval;
+ }
+ die $@ if $@;
+
+#cache it unless we're cleaning out each time
+ $Cache{$package}{mtime} = $mtime unless $delete;
+}
+
+eval {$package->handler;};
+die $@ if $@;
+
+delete_package($package) if $delete;
+
+#take a look if you want
+#print Devel::Symdump->rnew($package)->as_string, $/;
+}
+
+1;
+
+__END__
projects / spider.git / commitdiff