Upgrade 4.0.17 clean.
[usit-rt.git] / lib / RT / Interface / REST.pm
1 # BEGIN BPS TAGGED BLOCK {{{
2 #
3 # COPYRIGHT:
4 #
5 # This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
6 #                                          <sales@bestpractical.com>
7 #
8 # (Except where explicitly superseded by other copyright notices)
9 #
10 #
11 # LICENSE:
12 #
13 # This work is made available to you under the terms of Version 2 of
14 # the GNU General Public License. A copy of that license should have
15 # been provided with this software, but in any event can be snarfed
16 # from www.gnu.org.
17 #
18 # This work is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21 # General Public License for more details.
22 #
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
28 #
29 #
30 # CONTRIBUTION SUBMISSION POLICY:
31 #
32 # (The following paragraph is not intended to limit the rights granted
33 # to you to modify and distribute this software under the terms of
34 # the GNU General Public License and is only of importance to you if
35 # you choose to contribute your changes and enhancements to the
36 # community by submitting them to Best Practical Solutions, LLC.)
37 #
38 # By intentionally submitting any modifications, corrections or
39 # derivatives to this work, or any other work intended for use with
40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
41 # you are the copyright holder for those contributions and you grant
42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
43 # royalty-free, perpetual, license to use, copy, create derivative
44 # works based on those contributions, and sublicense and distribute
45 # those contributions and any derivatives thereof.
46 #
47 # END BPS TAGGED BLOCK }}}
48
49 package RT::Interface::REST;
50 use strict;
51 use warnings;
52 use RT;
53
54 use base 'Exporter';
55 our @EXPORT = qw(expand_list form_parse form_compose vpush vsplit process_attachments);
56
57 sub custom_field_spec {
58     my $self    = shift;
59     my $capture = shift;
60
61     my $CF_name = '[^,]+';
62     $CF_name = '(' . $CF_name . ')' if $capture;
63
64     my $new_style = 'CF\.\{'.$CF_name.'\}';
65     my $old_style = 'C(?:ustom)?F(?:ield)?-'.$CF_name;
66
67     return '(?i:' . join('|', $new_style, $old_style) . ')';
68 }
69
70 sub field_spec {
71     my $self    = shift;
72     my $capture = shift;
73
74     my $field = '[a-z][a-z0-9_-]*';
75     $field = '(' . $field . ')' if $capture;
76
77     my $custom_field = __PACKAGE__->custom_field_spec($capture);
78
79     return '(?i:' . join('|', $field, $custom_field) . ')';
80 }
81
82 # WARN: this code is duplicated in bin/rt.in,
83 # change both functions at once
84 sub expand_list {
85     my ($list) = @_;
86
87     my @elts;
88     foreach (split /\s*,\s*/, $list) {
89         push @elts, /^(\d+)-(\d+)$/? ($1..$2): $_;
90     }
91
92     return map $_->[0], # schwartzian transform
93         sort {
94             defined $a->[1] && defined $b->[1]?
95                 # both numbers
96                 $a->[1] <=> $b->[1]
97                 :!defined $a->[1] && !defined $b->[1]?
98                     # both letters
99                     $a->[2] cmp $b->[2]
100                     # mix, number must be first
101                     :defined $a->[1]? -1: 1
102         }
103         map [ $_, (defined( /^(\d+)$/ )? $1: undef), lc($_) ],
104         @elts;
105 }
106
107 # Returns a reference to an array of parsed forms.
108 sub form_parse {
109     my $state = 0;
110     my @forms = ();
111     my @lines = split /\n/, $_[0];
112     my ($c, $o, $k, $e) = ("", [], {}, "");
113     my $field = __PACKAGE__->field_spec;
114
115     LINE:
116     while (@lines) {
117         my $line = shift @lines;
118
119         next LINE if $line eq '';
120
121         if ($line eq '--') {
122             # We reached the end of one form. We'll ignore it if it was
123             # empty, and store it otherwise, errors and all.
124             if ($e || $c || @$o) {
125                 push @forms, [ $c, $o, $k, $e ];
126                 $c = ""; $o = []; $k = {}; $e = "";
127             }
128             $state = 0;
129         }
130         elsif ($state != -1) {
131             if ($state == 0 && $line =~ /^#/) {
132                 # Read an optional block of comments (only) at the start
133                 # of the form.
134                 $state = 1;
135                 $c = $line;
136                 while (@lines && $lines[0] =~ /^#/) {
137                     $c .= "\n".shift @lines;
138                 }
139                 $c .= "\n";
140             }
141             elsif ($state <= 1 && $line =~ /^($field):(?:\s+(.*))?$/i) {
142                 # Read a field: value specification.
143                 my $f  = $1;
144                 my @v  = ($2);
145                 $v[0] = '' unless defined $v[0];
146
147                 # Read continuation lines, if any.
148                 while (@lines && ($lines[0] eq '' || $lines[0] =~ /^\s+/)) {
149                     push @v, shift @lines;
150                 }
151                 pop @v while (@v && $v[-1] eq '');
152
153                 # Strip longest common leading indent from text.
154                 my $ws = ("");
155                 foreach my $ls (map {/^(\s+)/} @v[1..$#v]) {
156                     $ws = $ls if (!$ws || length($ls) < length($ws));
157                 }
158                 s/^$ws// foreach @v;
159
160                 shift @v while (@v && $v[0] eq '');
161
162                 push(@$o, $f) unless exists $k->{$f};
163                 vpush($k, $f, join("\n", @v));
164
165                 $state = 1;
166             }
167             elsif ($line =~ /^#/) {
168                 # We've found a syntax error, so we'll reconstruct the
169                 # form parsed thus far, and add an error marker. (>>)
170                 $state = -1;
171                 $e = form_compose([[ "", $o, $k, "" ]]);
172                 $e.= $line =~ /^>>/ ? "$line\n" : ">> $line\n";
173             }
174         }
175         else {
176             # We saw a syntax error earlier, so we'll accumulate the
177             # contents of this form until the end.
178             $e .= "$line\n";
179         }
180     }
181     push(@forms, [ $c, $o, $k, $e ]) if ($e || $c || @$o);
182
183     foreach my $l (keys %$k) {
184         $k->{$l} = vsplit($k->{$l}) if (ref $k->{$l} eq 'ARRAY');
185     }
186
187     return \@forms;
188 }
189
190 # Returns text representing a set of forms.
191 sub form_compose {
192     my ($forms) = @_;
193     my (@text);
194
195     foreach my $form (@$forms) {
196         my ($c, $o, $k, $e) = @$form;
197         my $text = "";
198
199         if ($c) {
200             $c =~ s/\n*$/\n/;
201             $text = "$c\n";
202         }
203         if ($e) {
204             $text .= $e;
205         }
206         elsif ($o) {
207             my (@lines);
208
209             foreach my $key (@$o) {
210                 my ($line, $sp);
211                 my @values = (ref $k->{$key} eq 'ARRAY') ?
212                                @{ $k->{$key} } :
213                                   $k->{$key};
214
215                 $sp = " "x(length("$key: "));
216                 $sp = " "x4 if length($sp) > 16;
217
218                 foreach my $v (@values) {
219                     $v = '' unless defined $v;
220                     if ( $v =~ /\n/) {
221                         $v =~ s/^/$sp/gm;
222                         $v =~ s/^$sp//;
223
224                         if ($line) {
225                             push @lines, "$line\n\n";
226                             $line = "";
227                         }
228                         elsif (@lines && $lines[-1] !~ /\n\n$/) {
229                             $lines[-1] .= "\n";
230                         }
231                         push @lines, "$key: $v\n\n";
232                     }
233                     elsif ($line &&
234                            length($line)+length($v)-rindex($line, "\n") >= 70)
235                     {
236                         $line .= ",\n$sp$v";
237                     }
238                     else {
239                         $line = $line ? "$line, $v" : "$key: $v";
240                     }
241                 }
242
243                 $line = "$key:" unless @values;
244                 if ($line) {
245                     if ($line =~ /\n/) {
246                         if (@lines && $lines[-1] !~ /\n\n$/) {
247                             $lines[-1] .= "\n";
248                         }
249                         $line .= "\n";
250                     }
251                     push @lines, "$line\n";
252                 }
253             }
254
255             $text .= join "", @lines;
256         }
257         else {
258             chomp $text;
259         }
260         push @text, $text;
261     }
262
263     return join "\n--\n\n", @text;
264 }
265
266 # Add a value to a (possibly multi-valued) hash key.
267 sub vpush {
268     my ($hash, $key, $val) = @_;
269     my @val = ref $val eq 'ARRAY' ? @$val : $val;
270
271     if (exists $hash->{$key}) {
272         unless (ref $hash->{$key} eq 'ARRAY') {
273             my @v = $hash->{$key} ne '' ? $hash->{$key} : ();
274             $hash->{$key} = \@v;
275         }
276         push @{ $hash->{$key} }, @val;
277     }
278     else {
279         $hash->{$key} = $val;
280     }
281 }
282
283 # "Normalise" a hash key that's known to be multi-valued.
284 sub vsplit {
285     my ($val) = @_;
286     my @words;
287
288     foreach my $line (map {split /\n/} (ref $val eq 'ARRAY') ? @$val : ($val||''))
289     {
290         # XXX: This should become a real parser, ? la Text::ParseWords.
291         $line =~ s/^\s+//;
292         $line =~ s/\s+$//;
293         push @words, split /\s*,\s*/, $line;
294     }
295
296     return \@words;
297 }
298
299 sub process_attachments {
300     my $entity = shift;
301     my @list = @_;
302     return 1 unless @list;
303
304     my $m = $HTML::Mason::Commands::m;
305     my $cgi = $m->cgi_object;
306
307     my $i = 1;
308     foreach my $e ( @list ) {
309
310         my $fh = $cgi->upload("attachment_$i");
311         return (0, "No attachment for $e") unless $fh;
312
313         local $/=undef;
314
315         my $file = $e;
316         $file =~ s#^.*[\\/]##;
317
318         my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
319
320         my $buf;
321         while (sysread($fh, $buf, 8192)) {
322             syswrite($tmp_fh, $buf);
323         }
324
325         my $info = $cgi->uploadInfo($fh);
326         my $new_entity = $entity->attach(
327             Path => $tmp_fn,
328             Type => $info->{'Content-Type'} || guess_media_type($tmp_fn),
329             Filename => $file,
330             Disposition => "attachment",
331         );
332         $new_entity->bodyhandle->{'_dirty_hack_to_save_a_ref_tmp_fh'} = $tmp_fh;
333         $i++;
334     }
335     return (1);
336 }
337
338 RT::Base->_ImportOverlays();
339
340 1;
341
342 =head1 NAME
343
344   RT::Interface::REST - helper functions for the REST interface.
345
346 =head1 SYNOPSIS
347
348   Only the REST should use this module.