The input line is now split into separate tokens which are either quoted or
unquoted strings. This simplifies e.g. the parsing of identifiers as the whole
token may be interpreted as just the id string. This allows for specifying a
somewhat greedy regex which before led to the whole remainder of the input
line ending up in the type or type instance.
+sub tokenize {
+ my $line = shift || return;
+ my $line_ptr = $line;
+ my @line = ();
+
+ my $token_pattern = qr/[^"\s]+|"[^"]+"/;
+
+ while (my ($token) = $line_ptr =~ m/^($token_pattern)\s+/) {
+ $line_ptr = $';
+ push @line, $token;
+ }
+
+ if ($line_ptr =~ m/^$token_pattern$/) {
+ push @line, $line_ptr;
+ }
+ else {
+ my ($token) = split m/ /, $line_ptr, 1;
+ print STDERR "Failed to parse line: $line\n";
+ print STDERR "Parse error near token \"$token\".\n";
+ return;
+ }
+
+ foreach my $l (@line) {
+ if ($l =~ m/^"(.*)"$/) {
+ $l = $1;
+ }
+ }
+ return @line;
+}
+
sub getid {
my $string = shift || return;
sub getid {
my $string = shift || return;
my ($h, $p, $pi, $t, $ti) =
my ($h, $p, $pi, $t, $ti) =
- $$string =~ m#^([^/]+)/([^/-]+)(?:-([^/]+))?/([^/-]+)(?:-([^/]+))?\s*#;
- $$string = $';
+ $string =~ m#^([^/]+)/([^/-]+)(?:-([^/]+))?/([^/-]+)(?:-([^/]+))?\s*#;
+ $string = $';
return if ((! $h) || (! $p) || (! $t));
return if ((! $h) || (! $p) || (! $t));
-=item B<GETVAL> I<Identifier>
+=item B<PUTVAL> I<Identifier> I<Valuelist>
my $sock = shift || return;
my $line = shift || return;
my $sock = shift || return;
my $line = shift || return;
- my $id = getid(\$line);
+ my @line = tokenize($line);
+ if (! @line) {
+ return;
+ }
+
+ if (scalar(@line) < 2) {
+ print STDERR "Synopsis: PUTVAL <id> <value0> [<value1> ...]" . $/;
+ return;
+ }
+
+ $id = getid($line[0]);
+
- print STDERR "Invalid id \"$line\"." . $/;
+ print STDERR "Invalid id \"$line[0]\"." . $/;
-=item B<PUTVAL> I<Identifier> I<Valuelist>
+=item B<GETVAL> I<Identifier>
my $sock = shift || return;
my $line = shift || return;
my $sock = shift || return;
my $line = shift || return;
- my $id = getid(\$line);
+ my @line = tokenize($line);
+
+ my $id;
+ my $vals;
+
+ if (! @line) {
+ return;
+ }
+
+ if (scalar(@line) < 1) {
+ print STDERR "Synopsis: GETVAL <id>" . $/;
+ return;
+ }
+
+ $id = getid($line[0]);
- print STDERR "Invalid id \"$line\"." . $/;
+ print STDERR "Invalid id \"$line[0]\"." . $/;
- my $vals = $sock->getval(%$id);
+ $vals = $sock->getval(%$id);
if (! $vals) {
print STDERR "socket error: " . $sock->{'error'} . $/;
if (! $vals) {
print STDERR "socket error: " . $sock->{'error'} . $/;
my $sock = shift || return;
my $line = shift;
my $sock = shift || return;
my $line = shift;
+ my @line = tokenize($line);
+
- foreach my $i (split m/ /, $line) {
+ foreach my $i (@line) {
my ($option, $value) = $i =~ m/^([^=]+)=(.+)$/;
next if (! ($option && $value));
my ($option, $value) = $i =~ m/^([^=]+)=(.+)$/;
next if (! ($option && $value));
sub listval {
my $sock = shift || return;
sub listval {
my $sock = shift || return;
+ if ($line ne "") {
+ print STDERR "Synopsis: LISTVAL" . $/;
+ return;
+ }
+
@res = $sock->listval();
if (! @res) {
@res = $sock->listval();
if (! @res) {
my $sock = shift || return;
my $line = shift || return;
my $sock = shift || return;
my $line = shift || return;
+ my @line = tokenize($line);
+
my $ret;
my (%values) = ();
my $ret;
my (%values) = ();
- foreach my $i (split m/ /, $line) {
- my($key,$val) = split m/=/, $i, 2;
+ foreach my $i (@line) {
+ my ($key, $val) = split m/=/, $i, 2;
if ($key && $val) {
$values{$key} = $val;
}
else {
if ($key && $val) {
$values{$key} = $val;
}
else {
- $values{'message'} .= ' '.$key;
+ $values{'message'} = defined($values{'message'})
+ ? ($values{'message'} . ' ' . $key)
+ : $key;
}
}
$values{'time'} ||= time();
}
}
$values{'time'} ||= time();