created mirror
This commit is contained in:
whatever
63
Perl/PerlServImpl.pm
Normal file
63
Perl/PerlServImpl.pm
Normal file
@@ -0,0 +1,63 @@
|
||||
#
|
||||
# PerlServImpl.pm
|
||||
#
|
||||
# Copyright (c) 1999, Tuomas Lukka
|
||||
#
|
||||
# You may use and distribute under the terms of either the GNU Lesser
|
||||
# General Public License, either version 2 of the license or,
|
||||
# at your choice, any later version. Alternatively, you may use and
|
||||
# distribute under the terms of the XPL.
|
||||
#
|
||||
# See the LICENSE.lgpl and LICENSE.xpl files for the specific terms of
|
||||
# the licenses.
|
||||
#
|
||||
# This software is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the README
|
||||
# file for more details.
|
||||
|
||||
|
||||
FOR A MODEL ONLY - COPY & IMPLEMENT
|
||||
|
||||
# ref & lock handled by the sessions...
|
||||
|
||||
# gethead, sethead not implemented
|
||||
#
|
||||
sub _c_get {
|
||||
my($this, $sess, $cfrom, $dim, $dir) = @_;
|
||||
}
|
||||
sub _c_new {
|
||||
my($this, $sess, $cfrom, $dim, $dir) = @_;
|
||||
}
|
||||
sub _c_delete {
|
||||
my($this, $sess, $cell) = @_;
|
||||
}
|
||||
sub _c_connect {
|
||||
my($this, $sess, $cfrom, $dim, $cto) = @_;
|
||||
}
|
||||
sub _c_insert {
|
||||
my($this, $sess, $cfrom, $dim, $dir, $cto) = @_;
|
||||
}
|
||||
sub _c_disconnect {
|
||||
my($this, $sess, $cfrom, $dim, $dir) = @_;
|
||||
}
|
||||
sub _c_gettext {
|
||||
my($this, $sess, $cell) = @_;
|
||||
}
|
||||
sub _c_settext {
|
||||
my($this, $sess, $cell) = @_;
|
||||
}
|
||||
sub _c_ref {
|
||||
my($this, $cell, $ref) = @_;
|
||||
}
|
||||
sub _c_lock {
|
||||
my($this, $cell, $lock) = @_;
|
||||
}
|
||||
sub _c_unlock {
|
||||
my($this, $cell, $lock) = @_;
|
||||
}
|
||||
sub _c_execute {
|
||||
my($this, $script, $obj, $ctrl, $view) = @_;
|
||||
}
|
||||
|
||||
|
||||
5
Perl/README
Normal file
5
Perl/README
Normal file
@@ -0,0 +1,5 @@
|
||||
This directory contains various hacks related to the client-server
|
||||
protocol. Not necessarily usable in its current form. Use the stuff
|
||||
in the ../Java/ directory.
|
||||
|
||||
Tuomas
|
||||
137
Perl/ZZPerlDBServ.pm
Normal file
137
Perl/ZZPerlDBServ.pm
Normal file
@@ -0,0 +1,137 @@
|
||||
#
|
||||
# ZZPerlDBServ.pm
|
||||
#
|
||||
# Copyright (c) 1999, Tuomas Lukka
|
||||
#
|
||||
# You may use and distribute under the terms of either the GNU Lesser
|
||||
# General Public License, either version 2 of the license or,
|
||||
# at your choice, any later version. Alternatively, you may use and
|
||||
# distribute under the terms of the XPL.
|
||||
#
|
||||
# See the LICENSE.lgpl and LICENSE.xpl files for the specific terms of
|
||||
# the licenses.
|
||||
#
|
||||
# This software is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the README
|
||||
# file for more details.
|
||||
|
||||
|
||||
package ZZPHash;
|
||||
require Tie::Hash;
|
||||
@ISA='Tie::StdHash';
|
||||
sub TIEHASH {
|
||||
bless $_[1], $_[0];
|
||||
}
|
||||
sub STORE {
|
||||
$_[0]->{$_[1]} = $_[2];
|
||||
print "STORED: '$_[1]' '$_[2]'\n";
|
||||
}
|
||||
sub DELETE {
|
||||
my $r0 = $_[0]->{$_[1]};
|
||||
my $r = delete $_[0]->{$_[1]};
|
||||
print "DELETED: '$_[1]' ( = '$r0' '$r')\n";
|
||||
return $r0;
|
||||
}
|
||||
|
||||
sub sync { tied (%{$_[0]})->sync }
|
||||
|
||||
package ZZPerlDBServ;
|
||||
use base ZZPerlServ;
|
||||
use DB_File;
|
||||
|
||||
sub _init_zzspace {
|
||||
my($this) = @_;
|
||||
my $db = $this->{DB};
|
||||
$db->{1} = "Home";
|
||||
$db->{Newno} = 42;
|
||||
$db->{Inited} = 1;
|
||||
}
|
||||
|
||||
sub _c__reallynew {
|
||||
my($this) = @_;
|
||||
my $n = $this->{DB}->{Newno}++;
|
||||
$db->{$n} = "";
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub new {
|
||||
my($type, $id, $port, $dbf) = @_;
|
||||
my $this = $type->SUPER::new($id,$port);
|
||||
my %h;
|
||||
tie %h, DB_File, $dbf, &O_RDWR|&O_CREAT, 0640, $DB_HASH;
|
||||
$this->{DB} = \%h;
|
||||
my %h2;
|
||||
tie %h2, ZZPHash, $this->{DB};
|
||||
$this->{DB} = \%h2;
|
||||
$this->_init_zzspace() unless $this->{DB}{Inited};
|
||||
|
||||
Event->timer(
|
||||
interval => 2,
|
||||
cb => sub { $this->sync() }
|
||||
);
|
||||
return $this;
|
||||
}
|
||||
|
||||
# gethead, sethead not implemented
|
||||
#
|
||||
sub _c_get {
|
||||
my($this, $sess, $cfrom, $dim, $dir) = @_;
|
||||
my $c = $this->{DB}{$cfrom.$dir.$dim};
|
||||
$c += 0; # Undef -> 0
|
||||
return $c;
|
||||
}
|
||||
|
||||
sub _c_delete {
|
||||
my($this, $sess, $cell) = @_;
|
||||
my @chg;
|
||||
for(@{$this->{Dims}}) {
|
||||
my $c;
|
||||
push @chg, $c = delete $this->{DB}{$cell."+".$_};
|
||||
delete $this->{DB}{$c."-".$_} if $c;
|
||||
push @chg, $c = delete $this->{DB}{$cell."-".$_};
|
||||
delete $this->{DB}{$c."+".$_} if $c;
|
||||
}
|
||||
push @chg;
|
||||
$this->_chg(\@chg);
|
||||
$this->_del($cell);
|
||||
}
|
||||
sub _c_connect {
|
||||
my($this, $sess, $cfrom, $dim, $cto) = @_;
|
||||
my @chg;
|
||||
print "C_CONN $cfrom $dim $cto\n";
|
||||
my $c;
|
||||
push @chg, $c = delete $this->{DB}{$cfrom."+".$dim};
|
||||
delete $this->{DB}{$c."-".$dim} if $c;
|
||||
push @chg, $c = delete $this->{DB}{$cto."-".$dim};
|
||||
delete $this->{DB}{$c."+".$dim} if $c;
|
||||
$this->{DB}{$cfrom."+".$dim} = $cto;
|
||||
$this->{DB}{$cto."-".$dim} = $cfrom;
|
||||
$this->_chg(@chg, $cfrom, $cto);
|
||||
}
|
||||
sub _c_disconnect {
|
||||
my($this, $sess, $cfrom, $dim, $dir) = @_;
|
||||
print "C_DISCONN $cfrom $dim $dir\n";
|
||||
my $c = delete $this->{DB}{$cfrom.$dir.$dim};
|
||||
return unless $c;
|
||||
delete $this->{DB}{$c.(ZZPerlServ::oppdir($dir)).$dim};
|
||||
$this->_chg($cfrom, $c);
|
||||
}
|
||||
sub _c_gettext {
|
||||
my($this, $sess, $cell) = @_;
|
||||
my $v = $this->{DB}{$cell};
|
||||
if(!defined $v) {
|
||||
return "" if exists $this->{DB}{$cell};
|
||||
return undef;
|
||||
}
|
||||
return $v;
|
||||
}
|
||||
sub _c_settext {
|
||||
my($this, $sess, $cell, $text) = @_;
|
||||
$this->{DB}{$cell} = $text;
|
||||
$this->_chg($cell);
|
||||
}
|
||||
|
||||
sub sync { my($this) = @_; (tied %{$this->{DB}})->sync }
|
||||
|
||||
1;
|
||||
410
Perl/ZZPerlServ.pm
Normal file
410
Perl/ZZPerlServ.pm
Normal file
@@ -0,0 +1,410 @@
|
||||
#
|
||||
# ZZPerlServ.pm
|
||||
#
|
||||
# Copyright (c) 1999, Tuomas Lukka
|
||||
#
|
||||
# You may use and distribute under the terms of either the GNU Lesser
|
||||
# General Public License, either version 2 of the license or,
|
||||
# at your choice, any later version. Alternatively, you may use and
|
||||
# distribute under the terms of the XPL.
|
||||
#
|
||||
# See the LICENSE.lgpl and LICENSE.xpl files for the specific terms of
|
||||
# the licenses.
|
||||
#
|
||||
# This software is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the README
|
||||
# file for more details.
|
||||
|
||||
|
||||
|
||||
|
||||
package ZZPerlServ;
|
||||
use Event;
|
||||
use IO::Socket;
|
||||
|
||||
sub oppdir {
|
||||
return "-" if $_[0] eq "+";
|
||||
return "+" if $_[0] eq "-";
|
||||
die("INVALID DIR!");
|
||||
}
|
||||
|
||||
sub new {
|
||||
my($type, $id, $port) = @_;
|
||||
my $fh = IO::Socket::INET->new(
|
||||
Proto => 'tcp',
|
||||
LocalPort => $port,
|
||||
Listen => SOMAXCONN,
|
||||
Reuse => 1
|
||||
);
|
||||
my $this = bless {
|
||||
Id => $id,
|
||||
ConnId => 42,
|
||||
FH => $fh,
|
||||
}, $type;
|
||||
Event->io(
|
||||
fd => $fh,
|
||||
poll => 're',
|
||||
cb => sub {
|
||||
my $cfh = $fh->accept()
|
||||
or die("Couldn't set up client");
|
||||
# XXX autoflush?
|
||||
$this->newconnection($cfh);
|
||||
}
|
||||
);
|
||||
Event->idle(
|
||||
max => 2,
|
||||
cb => sub {
|
||||
$this->flush_changes();
|
||||
}
|
||||
);
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub newconnection {
|
||||
my($this, $fh) = @_;
|
||||
my $c = bless {
|
||||
FH => $fh,
|
||||
S => $this,
|
||||
Id => $this->{ConnId}++,
|
||||
}, ZZPerlConn;
|
||||
$this->{Sess}{$c} = $c;
|
||||
# XXX Weaken!!!
|
||||
$c->start();
|
||||
}
|
||||
|
||||
sub _c_new {
|
||||
my($this, $sess, $cfrom, $dim, $dir) = @_;
|
||||
my $cur = $this->{DB}{$cfrom.$dir.$dim};
|
||||
my $new = $this->_c__reallynew($sess);
|
||||
if(!$new) {
|
||||
return (0, "Couldn't create");
|
||||
}
|
||||
if($dir eq "-") {
|
||||
($cfrom, $cur) = ($cur, $cfrom);
|
||||
}
|
||||
# XXX Catch errors
|
||||
$this->_c_connect($sess, $cfrom, $dim, $new)
|
||||
if $cfrom;
|
||||
$this->_c_connect($sess, $new, $dim, $cur)
|
||||
if $cur;
|
||||
return ($new,"");
|
||||
}
|
||||
|
||||
sub _c_insert {
|
||||
my($this, $sess, $cfrom, $dim, $dir, $cto) = @_;
|
||||
print "INSERT $cfrom $dim $dir $cto\n";
|
||||
my $cm = $this->_c_get($sess, $cto, $dim, "-");
|
||||
my $cp = $this->_c_get($sess, $cto, $dim, "+");
|
||||
if($cm && $cp) {
|
||||
$this->_c_connect($sess, $cm, $dim, $cto);
|
||||
} else {
|
||||
print "CM: $cm CP: $cp\n";
|
||||
$this->_c_disconnect($sess, $cto, $dim, "-") if $cm;
|
||||
$this->_c_disconnect($sess, $cto, $dim, "+") if $cp;
|
||||
}
|
||||
my $c = $this->_c_get($sess, $cfrom, $dim, $dir);
|
||||
print "C: $c\n";
|
||||
# if($c == $cto) {
|
||||
# return;
|
||||
# }
|
||||
if($dir eq "+") {
|
||||
$this->_c_connect($sess, $cfrom, $dim, $cto);
|
||||
$this->_c_connect($sess, $cto, $dim, $c) if $c;
|
||||
} else {
|
||||
$this->_c_connect($sess, $cto, $dim, $cfrom);
|
||||
$this->_c_connect($sess, $c, $dim, $cto) if $c;
|
||||
}
|
||||
}
|
||||
|
||||
sub _c_ref {
|
||||
my($this, $sess, $cell, $ref) = @_;
|
||||
if(($this->{Fer}{$sess}{$cell} += $ref) <= 0) {
|
||||
delete $this->{Fer}{$sess}{$cell};
|
||||
}
|
||||
if(($this->{Ref}{$cell}{$sess} += $ref) <= 0) {
|
||||
delete $this->{Ref}{$cell}{$sess};
|
||||
if(!keys %{$this->{Ref}{$cell}}) {
|
||||
delete $this->{Ref}{$cell};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _chg {
|
||||
my $this = shift;
|
||||
if(ref $_[0]) {
|
||||
for(@{$_[0]}) {
|
||||
$this->{Chg}{$_} = 1;
|
||||
}
|
||||
} else {
|
||||
for(@_) {
|
||||
$this->{Chg}{$_} = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _del {
|
||||
my($this, $cell) = @_;
|
||||
for my $sess (keys %{$this->{Ref}{$cell}}) {
|
||||
$sess->change("-1 deleted($cell)\n");
|
||||
}
|
||||
delete $this->{Ref}{$cell};
|
||||
}
|
||||
|
||||
sub flush_changes {
|
||||
my($this) = @_;
|
||||
print "FLUSH!\n";
|
||||
for(keys %{$this->{Chg}}) {
|
||||
print "CELL: $_\n";
|
||||
for my $sess (keys %{$this->{Ref}{$_}}) {
|
||||
print "SESS: $sess CELL: $_\n";
|
||||
$this->{Sess}{$sess}->change("-1 changed($_)\n");
|
||||
}
|
||||
}
|
||||
%{$this->{Chg}} = ();
|
||||
}
|
||||
|
||||
# XXX What happens when deleting a cell being waited for locking
|
||||
sub _c_lock {
|
||||
my($this, $sess, $cell, $lock) = @_;
|
||||
my $l = {
|
||||
Sess => "$sess",
|
||||
N => $lock+0,
|
||||
};
|
||||
if($this->{Lock}{$cell}) {
|
||||
if($lock =~ /w/) {
|
||||
push @{$this->{Wait}{$cell}}, $l;
|
||||
# This will disable the filehandle in select.
|
||||
$this->{Waiting}{$sess} = 1;
|
||||
} elsif($lock =~ /a/) {
|
||||
push @{$this->{Wait}{$cell}}, $l;
|
||||
} else {
|
||||
#$sess->_send_wouldblock($cell);
|
||||
}
|
||||
} else {
|
||||
$this->{Lock}{$cell} = $l;
|
||||
if($lock =~ /a/) {
|
||||
$sess->_send_locked($cell);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub del_sess {
|
||||
my($this, $sess) = @_;
|
||||
# XXX HANDLE LOCKS!
|
||||
for(keys %{ $this->{Fer}{$sess} }) {
|
||||
delete $this->{Ref}{$_}{$sess};
|
||||
}
|
||||
delete $this->{Fer}{$sess};
|
||||
delete $this->{Sess}{$sess};
|
||||
}
|
||||
|
||||
sub _c_unlock {
|
||||
my($this, $sess, $cell, $lock) = @_;
|
||||
}
|
||||
sub _c_execute {
|
||||
my($this, $sess, $script, $obj, $ctrl, $view) = @_;
|
||||
}
|
||||
|
||||
|
||||
# Subclasses must implement
|
||||
# c_get, c_new, c_delete,...
|
||||
|
||||
package ZZPerlConn;
|
||||
|
||||
%clcom = (
|
||||
get => 5,
|
||||
gethead => 5,
|
||||
sethead => 3,
|
||||
new => 5,
|
||||
delete => 1,
|
||||
connect => 3,
|
||||
insert => 4,
|
||||
disconnect => 3,
|
||||
gettext => 1,
|
||||
settext => 2,
|
||||
ref => 2,
|
||||
lock => 2,
|
||||
unlock => 1,
|
||||
execute => 4,
|
||||
);
|
||||
%bincom = map {($_=>1)} qw/settext/;
|
||||
|
||||
%excom = (
|
||||
get => rl,
|
||||
gethead => rl,
|
||||
new => rl,
|
||||
);
|
||||
|
||||
%respcom = (
|
||||
get => cellno,
|
||||
gethead => cellno,
|
||||
sethead => ok,
|
||||
new => cellno,
|
||||
delete => ok,
|
||||
connect => ok,
|
||||
insert => ok,
|
||||
disconnect => ok,
|
||||
gettext => text,
|
||||
settext => ok,
|
||||
ref =>
|
||||
);
|
||||
|
||||
my $ip = qr/\((.*?)\)/;
|
||||
my @nip = (
|
||||
"",
|
||||
qr/$ip/,
|
||||
qr/$ip$ip/,
|
||||
qr/$ip$ip$ip/,
|
||||
qr/$ip$ip$ip$ip/,
|
||||
qr/$ip$ip$ip$ip$ip/,
|
||||
);
|
||||
|
||||
|
||||
use Fcntl;
|
||||
|
||||
sub start {
|
||||
my($this) = @_;
|
||||
$this->{FH}->print("ZZ(0.02)($this->{S}{Id})($this->{Id})\n");
|
||||
fcntl($this->{FH}, &O_NONBLOCK, $b);
|
||||
$this->{FH}->autoflush(1);
|
||||
$this->{State} = "init";
|
||||
my $buf = "";
|
||||
$this->{Watcher} = Event->io(
|
||||
fd => $this->{FH},
|
||||
poll => 're',
|
||||
cb => sub {
|
||||
my $b;
|
||||
print "GOTIN\n";
|
||||
my $l = $this->{FH}->sysread($b,1024);
|
||||
if(!$l) {
|
||||
$this->throwout(); return;
|
||||
}
|
||||
$buf .= $b;
|
||||
TRYMORE:
|
||||
my $got = 0;
|
||||
print "BUF: '$buf'\n";
|
||||
if(exists $this->{Binary}) {
|
||||
if(length($buf)>= $this->{Binary}) {
|
||||
$got=1;
|
||||
my $s = substr($buf, 0, $this->{Binary},"");
|
||||
print "$this->{Binary} str: '$s'\n";
|
||||
$this->binary_input($s);
|
||||
delete $this->{Binary};
|
||||
}
|
||||
} else {
|
||||
if($buf =~ /^(.*?)(?:\x0d\x0a?|\x0a\x0d?)/) {
|
||||
$got=1;
|
||||
my $line = $1;
|
||||
chomp $line;
|
||||
chomp $line;
|
||||
$buf =~ s/^(.*?(?:\x0d\x0a?|\x0a\x0d?))//;
|
||||
$this->input($line);
|
||||
}
|
||||
}
|
||||
goto TRYMORE if $got;
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub throwout {
|
||||
my($this, $msg) = @_;
|
||||
print "THROWING OUT $this: $msg\n";
|
||||
return unless defined $this->{Watcher};
|
||||
$this->{Watcher}->cancel();
|
||||
$this->{S}->del_sess($this);
|
||||
}
|
||||
|
||||
sub input {
|
||||
my($this, $line) = @_;
|
||||
print "IN: '$line'\n";
|
||||
for($this->{State}) {
|
||||
/normal/ and do {
|
||||
# print join ',', map {ord} split '', $line;
|
||||
# print "\n";
|
||||
$line =~ /^(\d+)\s+(\w+)/ or
|
||||
die("Illegal line '$line'");
|
||||
my $comid = $1;
|
||||
my $c = $2;
|
||||
if(!$clcom{$c}) {
|
||||
$this->throwout("Unknown command '$c'");
|
||||
return;
|
||||
}
|
||||
unless($line =~ /^\d+\s+\w+$nip[$clcom{$c}]$/) {
|
||||
$this->throwout("Need $clcom{$c} params for $c");
|
||||
return;
|
||||
}
|
||||
my @pars = map {defined $_ ? $_ : ()}
|
||||
($1, $2, $3, $4, $5);
|
||||
if($bincom{$c}) {
|
||||
$this->{BC} = $c;
|
||||
$this->{BCID} = $comid;
|
||||
$this->{BP} = \@pars;
|
||||
print "BPARS: @pars\n";
|
||||
$this->{Binary} = pop @pars;
|
||||
print "Bin: $this->{Binary}\n";
|
||||
} else {
|
||||
my $m = "_c_$c";
|
||||
my @l = $this->{S}->$m($this,@pars);
|
||||
my $rc = $respcom{$c};
|
||||
if($rc eq "cellno") {
|
||||
print "CELL: $l[0]\n";
|
||||
if(!$l[0]) {
|
||||
# $this->{FH}->print("$comid error(FROM CELLNO $l[1])\n");
|
||||
# NO SUCH CELL
|
||||
$this->{FH}->print("$comid cellno(0)\n");
|
||||
|
||||
last;
|
||||
}
|
||||
# assuming ref-lock.
|
||||
my $ref = $pars[-2];
|
||||
my $lock = $pars[-1];
|
||||
print "REF: $ref\n";
|
||||
$this->{S}->_c_ref($this,$l[0], $ref)
|
||||
if $ref;
|
||||
$this->{S}->_c_lock($this,$l[0], $ref)
|
||||
if $lock;
|
||||
$this->{FH}->print("$comid cellno($l[0])\n");
|
||||
} elsif($rc eq "ok") {
|
||||
$this->{FH}->print("$comid ok\n");
|
||||
} elsif($rc eq "text") {
|
||||
if(!defined $l[0]) {
|
||||
# $this->{FH}->print("$comid error(no such cell)\n");
|
||||
# last;
|
||||
$l[0] = "";
|
||||
}
|
||||
my $len = length $l[0];
|
||||
$this->{FH}->print("$comid text($pars[0])($len)\n$l[0]");
|
||||
}
|
||||
print "REPLIED!\n";
|
||||
}
|
||||
last;
|
||||
};
|
||||
/init/ and do {
|
||||
unless($line =~ /^ZZ$ip$ip$ip$/) {
|
||||
$this->throwout("Invalid startline");
|
||||
return;
|
||||
}
|
||||
$this->{CVer} = $1;
|
||||
$this->{CId} = $2;
|
||||
$this->{CSess} = $3;
|
||||
$this->{State} = normal;
|
||||
last;
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
sub change {
|
||||
my($this, $msg) = @_;
|
||||
$this->{FH}->print($msg);
|
||||
}
|
||||
|
||||
sub binary_input {
|
||||
my($this, $data) = @_;
|
||||
my $m = "_c_$this->{BC}";
|
||||
$this->{S}->$m($this,@{$this->{BP}}, $data);
|
||||
print "REPLIEDBIN!\n";
|
||||
$this->{FH}->print("$this->{BCID} ok\n");
|
||||
}
|
||||
|
||||
|
||||
111
Perl/ZZPerlSimpleClient.pm
Normal file
111
Perl/ZZPerlSimpleClient.pm
Normal file
@@ -0,0 +1,111 @@
|
||||
#
|
||||
# ZZPerlSimpleClient.pm
|
||||
#
|
||||
# Copyright (c) 1999, Tuomas Lukka
|
||||
#
|
||||
# You may use and distribute under the terms of either the GNU Lesser
|
||||
# General Public License, either version 2 of the license or,
|
||||
# at your choice, any later version. Alternatively, you may use and
|
||||
# distribute under the terms of the XPL.
|
||||
#
|
||||
# See the LICENSE.lgpl and LICENSE.xpl files for the specific terms of
|
||||
# the licenses.
|
||||
#
|
||||
# This software is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the README
|
||||
# file for more details.
|
||||
|
||||
|
||||
# Provides the same routines as are inside the C++ scriptAPI for
|
||||
# Perl, but using the remote interface.
|
||||
|
||||
package ZZPerlSimpleClient;
|
||||
use IO::Socket;
|
||||
use base Exporter;
|
||||
@EXPORT = qw/zzconnect get_cell new_cell delete_cell
|
||||
connect_cells insert_cells insert_cell disconnect get_text
|
||||
set_text/;
|
||||
|
||||
my $socket;
|
||||
my $reqno = 1;
|
||||
|
||||
sub zzconnect {
|
||||
my($hostport, $id) = @_;
|
||||
$socket = IO::Socket::INET->new(
|
||||
PeerAddr => $hostport, # host:port
|
||||
Proto => tcp,
|
||||
) or die("No socket: $!");
|
||||
$socket->autoflush(1);
|
||||
$init = <$socket>;
|
||||
print "INI: $init\n";
|
||||
$socket->print("ZZ(0.03)($id)(1)\n");
|
||||
}
|
||||
sub request {
|
||||
my($req, $resp) = @_;
|
||||
$reqno++;
|
||||
$socket->print("$reqno $req");
|
||||
while(<$socket>) {
|
||||
print "REP: $_\n";
|
||||
next unless s/^$reqno\s+//;
|
||||
unless(/^$resp\b/) {
|
||||
die("INVALID RESPONSE $_\n");
|
||||
}
|
||||
if($resp eq "ok") { return }
|
||||
if($resp eq "cellno") {
|
||||
/^cellno\((.*?)\)/ or die("INV $_");
|
||||
return $1;
|
||||
}
|
||||
if($resp eq "text") {
|
||||
/^text\((.*?)\)\((.*?)\)/ or die("INVT $_");
|
||||
my $nb = $2;
|
||||
my $res;
|
||||
my $b;
|
||||
my $n;
|
||||
my $cur;
|
||||
while($nb > $n) {
|
||||
$cur = read $socket, $b, $nb - $n;
|
||||
if($cur == 0) {
|
||||
die("NOR BYT");
|
||||
}
|
||||
$n += $cur;
|
||||
}
|
||||
return $b;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub get_cell {
|
||||
my($from, $dim, $dir) = @_;
|
||||
return request("get($from)($dim)($dir)(0)(0)\n", "cellno");
|
||||
}
|
||||
sub new_cell {
|
||||
my($from, $dim, $dir) = @_;
|
||||
return request("new($from)($dim)($dir)(0)(0)\n", "cellno");
|
||||
}
|
||||
sub delete_cell {
|
||||
my($cell) = @_;
|
||||
request("delete($cell)", "ok");
|
||||
}
|
||||
sub connect_cells {
|
||||
my($from, $dim, $other) = @_;
|
||||
return request("connect($from)($dim)($other)\n", "ok");
|
||||
}
|
||||
sub insert_cell {
|
||||
my($from, $dim, $dir, $other) = @_;
|
||||
return request("connect($from)($dim)($dir)($other)\n", "ok");
|
||||
}
|
||||
sub disconnect {
|
||||
my($from, $dim, $dir) = @_;
|
||||
return request("new($from)($dim)($dir)\n", "ok");
|
||||
}
|
||||
sub get_text {
|
||||
my($cell) = @_;
|
||||
return request("gettext($cell)\n", "text");
|
||||
}
|
||||
sub set_text {
|
||||
my($cell, $t) = @_;
|
||||
my $l = length $t;
|
||||
return request("settext($cell)($l)\n$t", "ok");
|
||||
}
|
||||
|
||||
33
Perl/cperl.pl
Normal file
33
Perl/cperl.pl
Normal file
@@ -0,0 +1,33 @@
|
||||
#
|
||||
# cperl.pl
|
||||
#
|
||||
# Copyright (c) 1999, Tuomas Lukka
|
||||
#
|
||||
# You may use and distribute under the terms of either the GNU Lesser
|
||||
# General Public License, either version 2 of the license or,
|
||||
# at your choice, any later version. Alternatively, you may use and
|
||||
# distribute under the terms of the XPL.
|
||||
#
|
||||
# See the LICENSE.lgpl and LICENSE.xpl files for the specific terms of
|
||||
# the licenses.
|
||||
#
|
||||
# This software is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the README
|
||||
# file for more details.
|
||||
|
||||
|
||||
|
||||
use lib ".";
|
||||
use ZZPerlSimpleClient;
|
||||
zzconnect('localhost:3546', foo);
|
||||
|
||||
print get_text(1),"\n";
|
||||
$x = new_cell(1,"d.1", "+");
|
||||
$y = get_cell($x,"d.1", "-");
|
||||
$z = get_cell(1,"d.1", "+");
|
||||
print "GOT: '$x' '$y' '$z'\n";
|
||||
set_text($x,"FOOFOO");
|
||||
|
||||
print "DONE!\n";
|
||||
|
||||
28
Perl/sperl.pl
Normal file
28
Perl/sperl.pl
Normal file
@@ -0,0 +1,28 @@
|
||||
#
|
||||
# sperl.pl
|
||||
#
|
||||
# Copyright (c) 1999, Tuomas Lukka
|
||||
#
|
||||
# You may use and distribute under the terms of either the GNU Lesser
|
||||
# General Public License, either version 2 of the license or,
|
||||
# at your choice, any later version. Alternatively, you may use and
|
||||
# distribute under the terms of the XPL.
|
||||
#
|
||||
# See the LICENSE.lgpl and LICENSE.xpl files for the specific terms of
|
||||
# the licenses.
|
||||
#
|
||||
# This software is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the README
|
||||
# file for more details.
|
||||
|
||||
|
||||
use lib ".";
|
||||
use ZZPerlDBServ;
|
||||
use Event loop;
|
||||
|
||||
$s = ZZPerlDBServ->new("S1",3546, "test.db");
|
||||
|
||||
print loop();
|
||||
print "OUT!\n";
|
||||
print $@;
|
||||
Reference in New Issue
Block a user