1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
package sexpr;
use strict;
use warnings;
use Exporter qw(import);
our @EXPORT = qw(sexpr_decode sexpr_encode);
{
# good thing perl is single threaded ;-)
my $PARSER = __PACKAGE__->parser;
sub sexpr_decode {
open local $PARSER->{input}, '<', \$_[0];
$PARSER->parse;
}
}
sub sexpr_encode {
my $list = shift;
return "'$list'" unless ref($list);
my $out = '(';
for my $item (@$list) {
if (ref($item) eq 'ARRAY') {
$out .= sexpr_encode($item);
} else {
$out .= "$item";
}
$out .= " ";
}
$out = substr $out, 0, -1 if (substr $out, -1 eq ' ');
$out .= ')';
return $out;
}
# declare keyword syntax regex
my $tokenize = qr/
\A
(?<open>\() |
(?<close>\)) |
(?<space>\s+) |
(?<comment>\#.+) |
(?<string>\".*?") |
(?<word>[^\s\(\)\#"']+)
/x;
sub parser {
my ($class, $input) = @_;
return bless {
input => $input,
buffer => '',
token => undef,
match => undef,
macros => {},
}, $class;
}
sub empty {
my $self = shift;
length($self->{buffer}) == 0 and eof($self->{input});
}
sub current {
my $self = shift;
unless (length($self->{buffer}) or eof($self->{input})) {
$self->{buffer} = readline($self->{input});
}
$self->{buffer};
}
sub token {
my $self = shift;
my $line = $self->current;
# cache token
return @$self{'token','match'} if $self->{token};
return unless length($line);
return unless $line =~ $tokenize;
@$self{'token','match'} = %+;
}
sub _shift {
my ($self) = @_;
my $length = length($self->{match});
@$self{'token','match'} = (undef,undef);
substr($self->{buffer}, 0, $length, '');
}
sub expect {
my ($self, $expect) = @_;
my ($token, $match) = $self->token;
die "Got $token but expected $expect" unless $expect eq $token;
$self->_shift;
}
sub peek {
my ($self, $expect) = @_;
my ($token, $match) = $self->token or return;
return $match if $token eq $expect;
}
sub skip {
my ($self, @possible) = @_;
my %check = map { $_ => 1 } @possible;
while (my ($token, $match) = $self->token) {
last unless $check{$token};
$self->_shift;
}
}
sub parse {
my $self = shift;
$self->skip('comment', 'space');
return if $self->empty;
$self->expect('open');
my @expr;
until ($self->peek('close')) {
die "Could not continue reading" if $self->empty;
my ($token, $what) = $self->token or
die "Could not read a token";
if ($token eq 'word' or $token eq 'string') {
push @expr, $self->_shift;
} elsif ($token eq 'open') {
push @expr, $self->parse;
} else {
$self->_shift;
}
}
$self->_shift;
return \@expr;
}
1;
|
