1#!/usr/bin/perl -c
2#  Copyright (c) 2017 Fastmail.  All rights reserved.
3#
4# Author: Bron Gondwana <brong@fastmail.fm>
5#
6# Redistribution and use in source and binary forms, with or without
7# modification, are permitted provided that the following conditions
8# are met:
9#
10# 1. Redistributions of source code must retain the above copyright
11#    notice, this list of conditions and the following disclaimer.
12#
13# 2. Redistributions in binary form must reproduce the above copyright
14#    notice, this list of conditions and the following disclaimer in
15#    the documentation and/or other materials provided with the
16#    distribution.
17#
18# 3. The name "Carnegie Mellon University" must not be used to
19#    endorse or promote products derived from this software without
20#    prior written permission. For permission or any other legal
21#    details, please contact
22#      Office of Technology Transfer
23#      Carnegie Mellon University
24#      5000 Forbes Avenue
25#      Pittsburgh, PA  15213-3890
26#      (412) 268-4387, fax: (412) 268-7395
27#      tech-transfer@andrew.cmu.edu
28#
29# 4. Redistributions of any form whatsoever must retain the following
30#    acknowledgment:
31#    "This product includes software developed by Computing Services
32#     at Carnegie Mellon University (http://www.cmu.edu/computing/)."
33#
34# CARNEGIE MELLON UNIVERSITY DISCLAIMS ALL WARRANTIES WITH REGARD TO
35# THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
36# AND FITNESS, IN NO EVENT SHALL CARNEGIE MELLON UNIVERSITY BE LIABLE
37# FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
38# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
39# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING
40# OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
41
42use strict;
43use warnings;
44
45package Cyrus::DList;
46
47use File::Temp;
48
49sub new_kvlist {
50  my $class = shift;
51  my $key = shift;
52
53  return bless {
54    type => 'kvlist',
55    key => $key,
56    data => [],
57  }, ref($class) || $class;
58}
59
60sub new_list {
61  my $class = shift;
62  my $key = shift;
63
64  return bless {
65    type => 'list',
66    key => $key,
67    data => [],
68  }, ref($class) || $class;
69}
70
71sub new_perl {
72  my $class = shift;
73  my $key = shift;
74  my $val = shift;
75  my $Self = $class->new_list(undef);
76  $Self->add_perl($key, $val);
77  return $Self->{data}[0];
78}
79
80sub add_perl {
81  my $Self = shift;
82  my $key = shift;
83  my $val = shift;
84
85  if (not ref($val)) {
86    $Self->add_atom($key, $val);
87  }
88
89  elsif (ref($val) eq 'ARRAY') {
90    my $child = $Self->add_list($key);
91    $child->add_perl(undef, $_) for @$val;
92  }
93
94  elsif (ref($val) eq 'HASH') {
95    my $child = $Self->add_kvlist($key);
96    $child->add_perl($_, $val->{$_}) for sort keys %$val;
97  }
98
99  elsif (ref($val) eq 'REF') {
100    my $item = $$val;
101    if (ref($item) eq 'ARRAY') {
102      $Self->add_file($key, @$item);
103    } else {
104      die "Unknown file format " . ref($item);
105    }
106  }
107
108  else {
109    die "UNKNOWN $key " . ref($val);
110  }
111}
112
113sub add_list {
114  my $Self = shift;
115  my $key = shift;
116
117  die unless $Self->{type} =~ m/list/;
118
119  my $res = bless {
120    type => 'list',
121    key => $key,
122    data => [],
123  };
124  push @{$Self->{data}}, $res;
125
126  return $res;
127}
128
129
130sub add_kvlist {
131  my $Self = shift;
132  my $key = shift;
133
134  die unless $Self->{type} =~ m/list/;
135
136  my $res = bless {
137    type => 'kvlist',
138    key => $key,
139    data => [],
140  };
141  push @{$Self->{data}}, $res;
142
143  return $res;
144}
145
146sub add_file {
147  my $Self = shift;
148  my $key = shift;
149  my $partition = shift;
150  my $guid = shift;
151  my $size = shift;
152  my $value = shift;
153
154  die unless $Self->{type} =~ m/list/;
155
156  my $res = bless {
157    type => 'file',
158    key => $key,
159    partition => $partition,
160    guid => $guid,
161    size => $size,
162    data => $value,
163  };
164  push @{$Self->{data}}, $res;
165
166  return $res;
167}
168
169sub add_atom {
170  my $Self = shift;
171  my $key = shift;
172  my $value = shift;
173
174  die unless $Self->{type} =~ m/list/;
175
176  my $res = bless {
177    type => 'atom',
178    key => $key,
179    data => $value,
180  };
181  push @{$Self->{data}}, $res;
182
183  return $res;
184}
185
186sub _getastring {
187  my $ref = shift;
188  return undef if $$ref eq '';
189  if ($$ref =~ m/^{/) {
190    $$ref =~ s/^{(\d+)\+?}\r?\n//; # strip literal spec
191    my $len = $1;
192    return substr($$ref, 0, $len, '');
193  }
194  if ($$ref =~ m/^"/) {
195    $$ref =~ s/^"((?:[^"\\]++|\\.)*+)"//;
196    return $1;
197  }
198  return _getword($ref);
199}
200
201sub _getword {
202  my $ref = shift;
203  $$ref =~ s/^([^\ \)]+)//;
204  my $res = $1;
205  return undef if $res eq 'NIL';
206  return $res;
207}
208
209# Great - custom magic
210sub _parse_string {
211  my $Self = shift;
212  my $ref = shift;
213  my $parsekey = shift;
214
215  my $key = '';
216
217  if ($parsekey) {
218    $key = _getword($ref);
219    $$ref =~ s/^\s+//;
220    die unless $$ref;
221  }
222
223  if ($$ref =~ s/^\(//) {
224    my $Child = $Self->add_list($key);
225    while ($$ref !~ s/^\)//) {
226      $$ref =~ s/^\s+//;
227      die unless $$ref;
228      $Child->_parse_string($ref, 0);
229      $$ref =~ s/^\s+//;
230    }
231  }
232
233  elsif ($$ref =~ s/^\%//) {
234    # kvlist
235    if ($$ref =~ s/^\(//) {
236      die unless $$ref;
237      my $Child = $Self->add_kvlist($key);
238      while (not ($$ref =~ s/^\)//)) {
239        $Child->_parse_string($ref, 1);
240        $$ref =~ s/^\s+//;
241      }
242    }
243    elsif ($$ref =~ s/^\{//) {
244      die unless $$ref;
245      my $partition = _getword($ref);
246      $$ref =~ s/^\s+//;
247      my $guid = _getword($ref);
248      $$ref =~ s/^\s+//;
249      my $size = _getword($ref);
250      $$ref =~ s/^}\r?\n//;
251      my $content = substr($$ref, 0, $size, '');
252      $Self->add_file($key, $partition, $guid, $size, $content);
253    }
254  }
255  else {
256    my $content = _getastring($ref);
257    $Self->add_atom($key, $content);
258  }
259}
260
261sub parse_string {
262  my $class = shift;
263  my $string = shift;
264  my $parsekey = shift;
265  my $base = $class->new_list();
266  $base->_parse_string(\$string, $parsekey);
267  return $base->{data}[0];
268}
269
270sub _printastring {
271  my $str = shift;
272  return 'NIL' unless defined $str;
273  if (length($str) < 1024) {
274    # atom - actually it's more than this, but this will do
275    if ($str =~ m/^\\?[A-Za-z0-9][A-Za-z0-9_]*$/ and $str ne 'NIL') {
276      return $str;
277    }
278    # quotable
279    if ($str !~ m/[\x80-\xff\r\n\"\%\\]/) {
280      return '"' . $str . '"';
281    }
282  }
283  return '{' . length($str) . "}\r\n" . $str;
284}
285
286sub as_string {
287  my $Self = shift;
288
289  if ($Self->{type} eq 'kvlist') {
290    my @items = map { _printastring($_->{key}) => $_->as_string() } @{$Self->{data}};
291    return '%(' . join(' ', @items) . ')';
292  }
293  elsif ($Self->{type} eq 'list') {
294    my @items = map { $_->as_string() } @{$Self->{data}};
295    return '(' . join(' ', @items) . ')';
296  }
297  elsif ($Self->{type} eq 'file') {
298    my @items = ($Self->{partition}, $Self->{guid}, $Self->{size});
299    return '%{' . join (' ', @items) . "}\r\n" . $Self->{data};
300  }
301  else {
302    return _printastring($Self->{data});
303  }
304}
305
306sub as_perl {
307  my $Self = shift;
308
309  if ($Self->{type} eq 'kvlist') {
310    return { map { $_->{key} => $_->as_perl() } @{$Self->{data}} };
311  }
312  elsif ($Self->{type} eq 'list') {
313    return [ map { $_->as_perl() } @{$Self->{data}} ];
314  }
315  elsif ($Self->{type} eq 'file') {
316    return \[ $Self->{partition}, $Self->{guid}, $Self->{size}, $Self->{data} ];
317  }
318  else {
319    return $Self->{data};
320  }
321}
322
323sub anyevent_read_type {
324  my ($handle, $cb, $parsekey) = @_;
325
326  my %obj;
327  %obj = (
328    data => '',
329    getline => sub {
330      if ($_[1] =~ m/(\d+)\+?\}$/) {
331        my $length = $1;
332        $obj{data} .= $_[1] . $_[2];
333        # compatible with both file literals and regular literals
334        $_[0]->unshift_read(chunk => $length, $obj{getliteral});
335      }
336      else {
337        my $dlist = Cyrus::DList->parse_string($obj{data} . $_[1], $parsekey);
338        $cb->($handle, $dlist);
339        %obj = (); # drop refs
340      }
341      1
342    },
343    getliteral => sub {
344      $obj{data} .= $_[1];
345      $_[0]->unshift_read (line => $obj{getline});
346      1
347    },
348  );
349
350  return sub {
351    $_[0]->unshift_read (line => $obj{getline});
352    1
353  };
354};
355
356sub anyevent_write_type {
357  my ($handle, $dlist, $printkey) = @_;
358  my $string = '';
359  $string .= _printastring($dlist->{key}) . ' ' if $printkey;
360  $string .= $dlist->as_string() . "\n";
361  $handle->push_write($string);
362}
363
3641;
365