# New Ticket Created by emilbarton
# Please include the string: [perl #126205]
# in the subject line of all future correspondence about this issue.
# <URL: https://rt.perl.org/Ticket/Display.html?id=126205 >
Hi,
I'm facing this error and don't understand why. I'm not able to tell if
its a bug or something wrong in my code. My Perl6 version is :
2015.07.1-185-gd8ef5ea built on MoarVM version 2015.07-108-g7e9f29e.
I've asked on #perl6 at freenode and didn't get an answer. There is a
gist at https://gist.github.com/emilbarton/41d3e7094dc0d6115c00 with
the same files as sent here (see the example at EOF for error
reproduction). The program I'm writing is my first in Perl6 and its
purpose is to serve and query Sqlite3 dbs. I erased as much as I could
of my code to let the bare error show, which doesn't make my attempted
script look very consistent.
Thank you in advance if you can tell me how to overcome this problem.
emilbarton
#!/usr/bin/env perl6
use v6;
use Terminal::ANSIColor;
use Readline;
## General variables:
if @*ARGS.elems < 3 { die "Usage: mytest maindb user password [sessionid] " }
my $sessionId = "0";
my $mainDb = @*ARGS[0];
my $User = @*ARGS[1];
my $Passwd = @*ARGS[2];
if @*ARGS[3] { $sessionId = @*ARGS[3] };
my ($s1,$s2,$s3);
my (@a1,@a2,@a3);
my (%h1, %h2, %h3, %Runtime);
## Server variables:
my $Name = 'mytest';
my $Host = "localhost";
my $Port = "6789";
my $u6Host = "localhost";
my Int $u6Port = 9876;
my $localHost = "localhost";
my $localTime = "+2:00:00";
my @Base = "db1", "db2";
my $debFlag = 1;
my $debCnt = 0;
## END Server variables.
## message variables:
my $DATA_SEP = "\x[001F]";
my $RES_SOH = "\x[0001]";
my $RES_STX = "\x[0002]";
my $Rcnt = 1;
## END message variables.
## Readline:
my $Readline = Readline.new;
## END Readline
my $Moment = DateTime.new(now);
say color('reset') && color('underline red'), $Moment~$localTime, color('reset');
## Read-Eval Loop:
while my $Input = $Readline.readline( "$Name? " ) {
my $sub = "main_loop_";
given $Input {
when /:i^\s*quit\s*$/ { exit 0 } # END quit
default {
my $res = test($Input);
say color('cyan'), $res, color('reset');
} # END
} # END given $response
} # END while
## END Read-Eval Loop.
## Subroutines:
## Debug some data:
sub deb_say($input,$orig){
my $sub = "deb_say_";
my $res = 0;
if $debFlag != 0 {
$res = $debCnt;
say $input ~ " -- at " ~ $orig ~ ": " ~ ++$debCnt ~ " (d=" ~ $debFlag ~ ")." ;
}
return ($res);
} ## END deb_say()
## Extract a result string:
sub extract_res ($str) {
my $sub = "extract_res_";
$str ~~ /^ (.*) $RES_SOH $RES_STX (.*)$/ ; #m:
my $header = $0; my $row = $1;
my @headers = split $RES_SOH, $header;
my @rows; my $n = 0;
while $row ~~ /^(<-[\x0002]>*)[\x0002].*$/ { #m: $RES_STX : char class doesn't interpolate.
@rows.push("$0\t");
$n++;
$row ~~ s/^<-[\x0002]>*[\x0002](.*)$/$0/; #s:s:
# say $row ~ "\n***\n";
if $n == @headers.elems { @rows.push("\n") ; $n = 0; }
}
@rows.push($row) unless @rows.elems > 0;
return @headers.join("\t") ~ "\n===\n" ~ @rows.join("");
} ## END extract_res().
## get_instant:
sub get_instant($input){
my $sub = "get_instant_";
my $res = $input;
$res ~~ s:i/^Instant\:(.+)$/$0/; #s:i/:
return ($res);
} ## END get_instant()
## Add separator chars:
sub tab_level ($n, $char) {
my $sub = "tab_level_";
my $seq;
$char = " " unless ($char.length > 0);
loop (my $c = 0; $c < $n; $c++) { $seq .= $char }
$seq ~= " " unless ($seq ~~ /$char/);
return $seq;
} ## END tab_level()
sub test ($input) {
my $sub = "test_";
my $conn = IO::Socket::INET.new(:host($u6Host), :port($u6Port));
$conn.print: "$Host$DATA_SEP$Port$DATA_SEP$mainDb$DATA_SEP$User$DATA_SEP$Passwd$DATA_SEP$sessionId$DATA_SEP$input";
my $ret = $conn.recv;
$conn.close;
return $ret;
} ## END test().
## END Subroutines.
=finish
Example:
run:
$ perl6 150927-problem_server.pl
in one terminal window, then:
$ perl6 150927-problem_client.pl db1 admin adminp
in another terminal window, then there type:
$ test 1
and see the resulting error in the first window:
2015-09-27T11:38:32Z+2:00:00
localhost|6789|db1|admin|adminp|0|test 1 -- at _parse_com_1: 1 (d=1).
2015-09-27T11:42:10Z+2:00:00 -- localhost : db1 : admin : 0 : test 1
recording new user..
localhost,6789,db1,admin,adminp -- at _record_user_2: 2 (d=1).
admin@db1 -- at Runtime_test_user_1: 3 (d=1).
Cannot assign to a readonly variable or a value
in block at 150927-problem.pl:187
in method test_user at 150927-problem.pl:184
in sub record_user at 150927-problem.pl:340
in block at 150927-problem.pl:242
in block <unit> at 150927-problem.pl:230
#!/usr/bin/env perl6
use v6;
use Terminal::ANSIColor;
use Readline;
## General variables:
my ($s1,$s2,$s3,$Moment);
my (@a1,@a2,@a3);
my (%h1, %h2, %h3, %Runtime);
## Server variables:
my @publicBase = ("db1", "db2");
my Int $publicPort = 9876;
my $DATA_SEP = "\x[001F]";
my $RES_SOH = "\x[0001]";
my $RES_STX = "\x[0002]";
our $localTime = "+2:00:00";
our $localHost = "localhost";
our @privateBase;
our $privateHost = "localhost";
our $privatePort = "8765";
our $privateUser = "admin";
our $privatePasswd = "adminp";
our $debFlag = 1;
our $debCnt = 0;
## END Server variables.
our regex sql { <[\w\s\,\;\:\!\?\'\+\-\*\°\@\#\(\)\/\\]> };
our regex prohibited { <-[\w\s\,\;\:\!\?\'\"\+\-\*\°\@\#\(\)\/\\]> };
our regex dquote { <[\"]> };
our regex squote { <[\']> };
class Account { # Unid user accounts are needed to avoid useless user tests.
has $.id;
has $.host;
has $.port;
has $.state;
has $.db;
has $.permission;
has $.passwd;
method update($h, $p, $db, $pw, $per, $sta){
my $methname = "_update_";
$!host = $h;
$!port = $p;
$!db = $db;
$!passwd = $pw;
$!permission = $per unless $per !~~ /\w+/;
$!state = $sta unless $sta !~~ /\w+/;
return self;
} ## END method update
} ## END class Account
class Host {
has $.host;
has $.port;
has $.db;
} ## END class Host
class Message {
has $!input;
has $!session;
has $!user;
has $!host;
has $!port;
has $!base;
has $!mode;
has $!password;
has Bool $.correct;
has @.output;
submethod BUILD(:$input, :$host, :$base, :$port, :$session, :$user, :$password){
my $methname = "_BUILD_";
$!input := $input;
$!session := $session;
$!host := $host;
$!base := $base;
$!port := $port;
$!user := $user;
$!password := $password;
if $session == 0 {
$!correct := False;
push @!output, "invalid sessionid";
return;
}
my @checked = self.check($input);
if @checked.elems > 0 {
$!correct := True;
}
else {
$!correct := False;
# throw an exception otherwise the rest fails;
}
deb_say("correct:"~$!correct,self.^name~$methname);
} ## END submethod BUILD
method check($m){
my $methname = "_check_";
deb_say("checking:"~$m,self.^name~$methname);
my @checked;
given $m {
my @matches = m:global/<dquote>+/; #m:
if @matches.elems % 2 !== 0 {
deb_say("odd number of double quotes",self.^name~$methname);
push @!output, "odd number of double quotes: "~@matches;
$!correct = False;
return @checked;
}
}
if $m ~~ /\w+/ {
unshift @checked, $m;
}
else {
deb_say("invalid message",self.^name~$methname);
push @!output, "invalid message";
$!correct = False;
return @checked;
}
#$m ~~ s:g:i / (<![\"]>*)(\")(<![\"]>*)(\")(<![\"]>*)/$0%Unid_In<rep_dquot>$2%Unid_In<rep_dquot>$4/;#s:
# other checkings here
deb_say("checked: "~@checked.elems~" clauses; ",self.^name~$methname);
# other uncorrectness results treated by Clause;
@checked;
} ## END method check
} ## END class Message
class User {
has $.id;
has $.session;
has $.state;
has Account @.account;
method add_account($u,$h,$p,$db,$pw){
my $methname = "_add_account_";
push @!account, Account.new(id => $u, host => $h, port => $p, db => $db, passwd => $pw );
} ## END method add_account
method get_account($u){
my $methname = "_get_account_";
my $out = 0;
if @!account.elems > 0 {
for @!account { if $_.id ~~ /^<$u>$/ { $out = $_; last } }
}
return $out;
} ## END method get_account
method update_account($u, $h, $p, $db, $pw, $per, $sta){
my $methname = "_update_account_";
my $account = 0;
if @!account.elems > 0 {
for @!account { if $_.id ~~ /^<$u>$/ { $account = $_; last } }
}
unless $account == 0 { return $account.update($u, $h, $p, $db, $pw, $per, $sta) }
$account;
} ## END method update_account
} ## END class User
class Runtime {
has $.start;
has User @.user;
method add_user ($s, $u, $h, $p, $db, $pw) {
my $methname = "_add_user_";
my $user = User.new(id => $u, session => $s, state => "new");
push @!user, $user;
$user.add_account($u, $h, $p, $db, $pw);
} ## END method add_user
method get_user ($u) {
my $methname = "_get_user_";
my $out = 0;
if @!user.elems > 0 {
for @!user { if $_.id ~~ /^<$u>$/ { $out = $_; last } }
}
return $out;
} ## END method get_user
method test_user($host,$port,$base,$user,$pw){
my $methname = "_test_user_";
my @auth =(1,2,3);
if @auth.elems > 2 {
my $test = "test OK: user not logged in: "~@!user.elems;
if @!user.elems > 0 {
for @!user {
deb_say($_.id,self.^name~$methname~"1");
if $_.id ~~ /^<$user>$/ {
$test = "test OK: user logged in: "~@!user.elems;
last;
} # END if $_.id
} # END for @!user
} # END if @!user.elems > 0
deb_say($test,self.^name~$methname~"3");
} # END if @auth.elems > 2
else { say("test: KO "~@auth.elems~" "~self.^name~$methname~"1") }
return @auth;
} ## END method test_user
method update_user ($i, $s, $u, $h, $p, $db, $pw, $per, $sta) {
my $methname = "_update_user_";
my $user = 0;
if @!user.elems > 0 {
for @!user { if $_.id ~~ /^<$u>$/ { $user = $_; $user.session = $i; $user.state = $s; last } }
}
unless $user == 0 { $user.update_account($u, $h, $p, $db, $pw, $per, $sta) }
return $user;
} ## END method update_user
} ## END class Runtime
## Readline:
my $Readline = Readline.new;
## END Readline
## Time
$Moment = DateTime.new(now);
say color('reset') && color('underline red'), $Moment~$localTime, color('reset');
## END Time
## Runtime
my $Run = Runtime.new(start => $Moment~$localTime);
push @privateBase, Host.new(db => $_, host => $privateHost, port => $privatePort ) for @publicBase;
## END Log
## Connection
my $Listen = IO::Socket::INET.new(:listen, :localport($publicPort));
## END Connection
## Read-Eval Loop:
loop { ## INET.pm
my $subname = '_main_loop_';
my $conn = $Listen.accept;
while my $input = $conn.recv(:bin) {
my $com = $input.decode('UTF-8');
my ($reqhost, $reqport, $reqdb, $requser, $reqpw, $reqsession, $request) := parse_com($com);
say DateTime.new(now)~$localTime~" -- "~$reqhost~" : "~$reqdb~" : "~$requser~" : "~$reqsession~" : "~$request;
# Open or append to session (->subdb users):
my ($sessionId, $lastCom);
my $recid = "0";
if $recid ~~ /^0$/ || $recid !~~ /\S+/ {
say "recording new user..";
$sessionId = record_user($requser,$reqhost,$reqport,$reqdb,$reqpw,$request);
}
else {
my $mode = $sessionId = "0";
if $Run.get_user("$requser\@$reqdb") !== 0 { # TODO: Handle also the case where user has closed session:
$sessionId = $Run.get_user("$requser\@$reqdb").session;
$mode = 1; ## Fresh session.
} # Update entry creating or not a new sessionId (has the user passed an old sessionId?).
if $reqsession !~~ /^0$/ && $Run.get_user("$requser\@$reqdb").state !~~ /^fresh$/ {
unless $Run.get_user("$requser\@$reqdb").test_session($reqsession) ~~ /^0$/ {
$sessionId = $_;
$mode = 2; ## Old session.
}
}
say "updating user entry..$recid";
$sessionId = update_user($recid,$requser,$reqhost,$reqport,$reqdb,$reqpw,$request,$sessionId,$mode);
}
my $mess = Message.new(input => $request, session => $sessionId, user => $requser, password => $reqpw, host => $reqhost, base => $reqdb, port => ~$reqport);
my $res = "session id:"~$sessionId ~ "\n";
if $mess.correct == False {
deb_say("invalid message",$subname~"2");
deb_say("session id:"~$sessionId,$subname~"3");
}
# else { $mess.compute(); }
$res = $res ~ $_ ~ "\n" for $mess.output;
$conn.print: $res ;
} ## END while $input
$conn.close;
} ## END Read-Eval Loop.
## Subroutines:
## Debug some data:
sub deb_say($input,$orig){
my $subname = '_deb_say_';
my $res = 0;
if $debFlag != 0 {
$res = $debCnt;
say $input ~ " -- at " ~ $orig ~ ": " ~ ++$debCnt ~ " (d=" ~ $debFlag ~ ")." ;
}
return ($res);
} ## END deb_say()
## Extract a result string: (the data structure has to be known beforehand)
sub extract_res ($str) {
my $subname = '_extract_res_';
unless $str ~~ /^ (.*) $RES_SOH $RES_STX (.*)$/ { return "0" } #m:
my $header = $0; my $row = "$1";
my @headers = split $RES_SOH, $header;
my @rows; my $n = 0;
while $row ~~ /^(<-[\x0002]>*)[\x0002].*$/ { #m: $RES_STX : char class doesn't interpolate.
@rows.push("$0\t");
$n++;
$row ~~ s/^<-[\x0002]>*[\x0002](.*)$/$0/; #s:s:
# say $row ~ "\n***\n";
if $n == @headers.elems { @rows.push("\n") ; $n = 0; }
}
@rows.push($row) unless @rows.elems > 0;
return @rows;
} ## END extract_res().
sub get_instant($input){
my $sub = "get_instant_";
my $res = $input;
$res ~~ s:i/^Instant\:(.+)$/$0/; #s:i/:
return ($res);
} ## END get_instant()
## Parse an incoming connection:
sub parse_com($input){
my $subname = '_parse_com_';
$input ~~ /^(\w+)$DATA_SEP(\d+)$DATA_SEP(\w+)$DATA_SEP(\w+)$DATA_SEP(\w+)$DATA_SEP(.+)$DATA_SEP(.+)$/;
my $reqhost = $0;
my $reqport = $1;
my $reqdb = $2;
my $requser = $3;
my $reqpassword = $4;
my $reqsession = $5;
my $request = $6;
deb_say($reqhost~"|"~$reqport~"|"~$reqdb~"|"~$requser~"|"~$reqpassword~"|"~$reqsession~"|"~$request,$subname~"1");
return ($reqhost,$reqport,$reqdb,$requser,$reqpassword,$reqsession,$request);
} ## END parse_com
## Create a new user entry
sub record_user ($requser,$reqhost,$reqport,$reqdb,$reqpw,$request){
my $subname = '_record_user_';
my $sessionid = get_instant(now);
deb_say("$reqhost,$reqport,$reqdb,$requser,$reqpw",$subname~"2");
## Let's record user info before testing it:
$Run.add_user($sessionid, "$requser\@$reqdb", $reqhost, $reqport, $reqdb, $reqpw);
$sessionid = 0 unless $Run.test_user($reqhost,$reqport,$reqdb,$requser,$reqpw).elems > 2 ; #m: $RES_STX : char class doesn't interpolate.;
return $sessionid;
} ## END record_user()
## Update user entry
sub update_user ($recid,$requser,$reqhost,$reqport,$reqdb,$reqpw,$request,$reqsession,$mode){
my $subname = '_update_user_';
my ($out, $req, $symid, $test);
my $sessionid = $reqsession;
$test = 0;
# sessionid can be an old session or 0 but also a fresh one.
# was sessionid provided by user?
# mode=0:new, mode=1:fresh, mode=2:old.
if $sessionid ~~ /^0$/ or $test == 1 {
$sessionid = get_instant(now) if $mode == 0;
say "session for "~$requser~"\@"~$reqdb~":"~$reqsession;
unless $mode == 1 {
return 0 unless $Run.test_user($reqhost,$reqport,$reqdb,$requser,$reqpw).elems > 2;
}
}
$Run.update_user($sessionid,"fresh","$requser\@$reqdb",$reqhost,$reqport,$reqdb,$reqpw,'','');
return $sessionid;
} ## END update_user()
## END Subroutines.
=finish
Example:
run:
$ perl6 150927-problem_server.pl
in one terminal window, then:
$ perl6 150927-problem_client.pl db1 admin adminp
in another terminal window, then there type:
$ test 1
and see the resulting error in the first window:
2015-09-27T11:38:32Z+2:00:00
localhost|6789|db1|admin|adminp|0|test 1 -- at _parse_com_1: 1 (d=1).
2015-09-27T11:42:10Z+2:00:00 -- localhost : db1 : admin : 0 : test 1
recording new user..
localhost,6789,db1,admin,adminp -- at _record_user_2: 2 (d=1).
admin@db1 -- at Runtime_test_user_1: 3 (d=1).
Cannot assign to a readonly variable or a value
in block at 150927-problem.pl:187
in method test_user at 150927-problem.pl:184
in sub record_user at 150927-problem.pl:340
in block at 150927-problem.pl:242
in block <unit> at 150927-problem.pl:230
