]>
Commit | Line | Data |
---|---|---|
84fb5b46 MKG |
1 | # BEGIN BPS TAGGED BLOCK {{{ |
2 | # | |
3 | # COPYRIGHT: | |
4 | # | |
403d7b0b | 5 | # This software is Copyright (c) 1996-2013 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; | |
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); | |
56 | ||
57 | sub custom_field_spec { | |
58 | my $self = shift; | |
59 | my $capture = shift; | |
60 | ||
403d7b0b | 61 | my $CF_name = '[^,]+'; |
84fb5b46 MKG |
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 | RT::Base->_ImportOverlays(); | |
300 | ||
301 | 1; | |
302 | ||
303 | =head1 NAME | |
304 | ||
305 | RT::Interface::REST - helper functions for the REST interface. | |
306 | ||
307 | =head1 SYNOPSIS | |
308 | ||
309 | Only the REST should use this module. |