]>
Commit | Line | Data |
---|---|---|
84fb5b46 MKG |
1 | # BEGIN BPS TAGGED BLOCK {{{ |
2 | # | |
3 | # COPYRIGHT: | |
4 | # | |
320f0092 | 5 | # This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC |
84fb5b46 MKG |
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; | |
320f0092 | 50 | use LWP::MediaTypes qw(guess_media_type); |
84fb5b46 MKG |
51 | use strict; |
52 | use warnings; | |
53 | use RT; | |
54 | ||
55 | use base 'Exporter'; | |
01e3b242 | 56 | our @EXPORT = qw(expand_list form_parse form_compose vpush vsplit process_attachments); |
84fb5b46 MKG |
57 | |
58 | sub custom_field_spec { | |
59 | my $self = shift; | |
60 | my $capture = shift; | |
61 | ||
403d7b0b | 62 | my $CF_name = '[^,]+'; |
84fb5b46 MKG |
63 | $CF_name = '(' . $CF_name . ')' if $capture; |
64 | ||
65 | my $new_style = 'CF\.\{'.$CF_name.'\}'; | |
66 | my $old_style = 'C(?:ustom)?F(?:ield)?-'.$CF_name; | |
67 | ||
68 | return '(?i:' . join('|', $new_style, $old_style) . ')'; | |
69 | } | |
70 | ||
71 | sub field_spec { | |
72 | my $self = shift; | |
73 | my $capture = shift; | |
74 | ||
75 | my $field = '[a-z][a-z0-9_-]*'; | |
76 | $field = '(' . $field . ')' if $capture; | |
77 | ||
78 | my $custom_field = __PACKAGE__->custom_field_spec($capture); | |
79 | ||
80 | return '(?i:' . join('|', $field, $custom_field) . ')'; | |
81 | } | |
82 | ||
83 | # WARN: this code is duplicated in bin/rt.in, | |
84 | # change both functions at once | |
85 | sub expand_list { | |
86 | my ($list) = @_; | |
87 | ||
88 | my @elts; | |
89 | foreach (split /\s*,\s*/, $list) { | |
90 | push @elts, /^(\d+)-(\d+)$/? ($1..$2): $_; | |
91 | } | |
92 | ||
93 | return map $_->[0], # schwartzian transform | |
94 | sort { | |
95 | defined $a->[1] && defined $b->[1]? | |
96 | # both numbers | |
97 | $a->[1] <=> $b->[1] | |
98 | :!defined $a->[1] && !defined $b->[1]? | |
99 | # both letters | |
100 | $a->[2] cmp $b->[2] | |
101 | # mix, number must be first | |
102 | :defined $a->[1]? -1: 1 | |
103 | } | |
104 | map [ $_, (defined( /^(\d+)$/ )? $1: undef), lc($_) ], | |
105 | @elts; | |
106 | } | |
107 | ||
108 | # Returns a reference to an array of parsed forms. | |
109 | sub form_parse { | |
110 | my $state = 0; | |
111 | my @forms = (); | |
112 | my @lines = split /\n/, $_[0]; | |
113 | my ($c, $o, $k, $e) = ("", [], {}, ""); | |
114 | my $field = __PACKAGE__->field_spec; | |
115 | ||
116 | LINE: | |
117 | while (@lines) { | |
118 | my $line = shift @lines; | |
119 | ||
120 | next LINE if $line eq ''; | |
121 | ||
122 | if ($line eq '--') { | |
123 | # We reached the end of one form. We'll ignore it if it was | |
124 | # empty, and store it otherwise, errors and all. | |
125 | if ($e || $c || @$o) { | |
126 | push @forms, [ $c, $o, $k, $e ]; | |
127 | $c = ""; $o = []; $k = {}; $e = ""; | |
128 | } | |
129 | $state = 0; | |
130 | } | |
131 | elsif ($state != -1) { | |
132 | if ($state == 0 && $line =~ /^#/) { | |
133 | # Read an optional block of comments (only) at the start | |
134 | # of the form. | |
135 | $state = 1; | |
136 | $c = $line; | |
137 | while (@lines && $lines[0] =~ /^#/) { | |
138 | $c .= "\n".shift @lines; | |
139 | } | |
140 | $c .= "\n"; | |
141 | } | |
142 | elsif ($state <= 1 && $line =~ /^($field):(?:\s+(.*))?$/i) { | |
143 | # Read a field: value specification. | |
144 | my $f = $1; | |
145 | my @v = ($2); | |
146 | $v[0] = '' unless defined $v[0]; | |
147 | ||
148 | # Read continuation lines, if any. | |
149 | while (@lines && ($lines[0] eq '' || $lines[0] =~ /^\s+/)) { | |
150 | push @v, shift @lines; | |
151 | } | |
152 | pop @v while (@v && $v[-1] eq ''); | |
153 | ||
154 | # Strip longest common leading indent from text. | |
155 | my $ws = (""); | |
156 | foreach my $ls (map {/^(\s+)/} @v[1..$#v]) { | |
157 | $ws = $ls if (!$ws || length($ls) < length($ws)); | |
158 | } | |
159 | s/^$ws// foreach @v; | |
160 | ||
161 | shift @v while (@v && $v[0] eq ''); | |
162 | ||
163 | push(@$o, $f) unless exists $k->{$f}; | |
164 | vpush($k, $f, join("\n", @v)); | |
165 | ||
166 | $state = 1; | |
167 | } | |
168 | elsif ($line =~ /^#/) { | |
169 | # We've found a syntax error, so we'll reconstruct the | |
170 | # form parsed thus far, and add an error marker. (>>) | |
171 | $state = -1; | |
172 | $e = form_compose([[ "", $o, $k, "" ]]); | |
173 | $e.= $line =~ /^>>/ ? "$line\n" : ">> $line\n"; | |
174 | } | |
175 | } | |
176 | else { | |
177 | # We saw a syntax error earlier, so we'll accumulate the | |
178 | # contents of this form until the end. | |
179 | $e .= "$line\n"; | |
180 | } | |
181 | } | |
182 | push(@forms, [ $c, $o, $k, $e ]) if ($e || $c || @$o); | |
183 | ||
184 | foreach my $l (keys %$k) { | |
185 | $k->{$l} = vsplit($k->{$l}) if (ref $k->{$l} eq 'ARRAY'); | |
186 | } | |
187 | ||
188 | return \@forms; | |
189 | } | |
190 | ||
191 | # Returns text representing a set of forms. | |
192 | sub form_compose { | |
193 | my ($forms) = @_; | |
194 | my (@text); | |
195 | ||
196 | foreach my $form (@$forms) { | |
197 | my ($c, $o, $k, $e) = @$form; | |
198 | my $text = ""; | |
199 | ||
200 | if ($c) { | |
201 | $c =~ s/\n*$/\n/; | |
202 | $text = "$c\n"; | |
203 | } | |
204 | if ($e) { | |
205 | $text .= $e; | |
206 | } | |
207 | elsif ($o) { | |
208 | my (@lines); | |
209 | ||
210 | foreach my $key (@$o) { | |
211 | my ($line, $sp); | |
212 | my @values = (ref $k->{$key} eq 'ARRAY') ? | |
213 | @{ $k->{$key} } : | |
214 | $k->{$key}; | |
215 | ||
216 | $sp = " "x(length("$key: ")); | |
217 | $sp = " "x4 if length($sp) > 16; | |
218 | ||
219 | foreach my $v (@values) { | |
220 | $v = '' unless defined $v; | |
221 | if ( $v =~ /\n/) { | |
222 | $v =~ s/^/$sp/gm; | |
223 | $v =~ s/^$sp//; | |
224 | ||
225 | if ($line) { | |
226 | push @lines, "$line\n\n"; | |
227 | $line = ""; | |
228 | } | |
229 | elsif (@lines && $lines[-1] !~ /\n\n$/) { | |
230 | $lines[-1] .= "\n"; | |
231 | } | |
232 | push @lines, "$key: $v\n\n"; | |
233 | } | |
234 | elsif ($line && | |
235 | length($line)+length($v)-rindex($line, "\n") >= 70) | |
236 | { | |
237 | $line .= ",\n$sp$v"; | |
238 | } | |
239 | else { | |
240 | $line = $line ? "$line, $v" : "$key: $v"; | |
241 | } | |
242 | } | |
243 | ||
244 | $line = "$key:" unless @values; | |
245 | if ($line) { | |
246 | if ($line =~ /\n/) { | |
247 | if (@lines && $lines[-1] !~ /\n\n$/) { | |
248 | $lines[-1] .= "\n"; | |
249 | } | |
250 | $line .= "\n"; | |
251 | } | |
252 | push @lines, "$line\n"; | |
253 | } | |
254 | } | |
255 | ||
256 | $text .= join "", @lines; | |
257 | } | |
258 | else { | |
259 | chomp $text; | |
260 | } | |
261 | push @text, $text; | |
262 | } | |
263 | ||
264 | return join "\n--\n\n", @text; | |
265 | } | |
266 | ||
267 | # Add a value to a (possibly multi-valued) hash key. | |
268 | sub vpush { | |
269 | my ($hash, $key, $val) = @_; | |
270 | my @val = ref $val eq 'ARRAY' ? @$val : $val; | |
271 | ||
272 | if (exists $hash->{$key}) { | |
273 | unless (ref $hash->{$key} eq 'ARRAY') { | |
274 | my @v = $hash->{$key} ne '' ? $hash->{$key} : (); | |
275 | $hash->{$key} = \@v; | |
276 | } | |
277 | push @{ $hash->{$key} }, @val; | |
278 | } | |
279 | else { | |
280 | $hash->{$key} = $val; | |
281 | } | |
282 | } | |
283 | ||
284 | # "Normalise" a hash key that's known to be multi-valued. | |
285 | sub vsplit { | |
286 | my ($val) = @_; | |
287 | my @words; | |
288 | ||
289 | foreach my $line (map {split /\n/} (ref $val eq 'ARRAY') ? @$val : ($val||'')) | |
290 | { | |
291 | # XXX: This should become a real parser, ? la Text::ParseWords. | |
292 | $line =~ s/^\s+//; | |
293 | $line =~ s/\s+$//; | |
294 | push @words, split /\s*,\s*/, $line; | |
295 | } | |
296 | ||
297 | return \@words; | |
298 | } | |
299 | ||
01e3b242 MKG |
300 | sub process_attachments { |
301 | my $entity = shift; | |
302 | my @list = @_; | |
303 | return 1 unless @list; | |
304 | ||
305 | my $m = $HTML::Mason::Commands::m; | |
306 | my $cgi = $m->cgi_object; | |
307 | ||
308 | my $i = 1; | |
309 | foreach my $e ( @list ) { | |
310 | ||
311 | my $fh = $cgi->upload("attachment_$i"); | |
312 | return (0, "No attachment for $e") unless $fh; | |
313 | ||
314 | local $/=undef; | |
315 | ||
316 | my $file = $e; | |
317 | $file =~ s#^.*[\\/]##; | |
318 | ||
319 | my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 ); | |
320 | ||
321 | my $buf; | |
322 | while (sysread($fh, $buf, 8192)) { | |
323 | syswrite($tmp_fh, $buf); | |
324 | } | |
325 | ||
326 | my $info = $cgi->uploadInfo($fh); | |
327 | my $new_entity = $entity->attach( | |
328 | Path => $tmp_fn, | |
329 | Type => $info->{'Content-Type'} || guess_media_type($tmp_fn), | |
330 | Filename => $file, | |
331 | Disposition => "attachment", | |
332 | ); | |
333 | $new_entity->bodyhandle->{'_dirty_hack_to_save_a_ref_tmp_fh'} = $tmp_fh; | |
334 | $i++; | |
335 | } | |
336 | return (1); | |
337 | } | |
338 | ||
84fb5b46 MKG |
339 | RT::Base->_ImportOverlays(); |
340 | ||
341 | 1; | |
342 | ||
343 | =head1 NAME | |
344 | ||
345 | RT::Interface::REST - helper functions for the REST interface. | |
346 | ||
347 | =head1 SYNOPSIS | |
348 | ||
349 | Only the REST should use this module. |