Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/String/Escape.pm |
Statements | Executed 84 statements in 4.31ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 739µs | 739µs | _define_backslash_escapes | String::Escape::
512 | 2 | 1 | 217µs | 217µs | CORE:unpack (opcode) | String::Escape::
1 | 1 | 1 | 30µs | 30µs | add | String::Escape::
1 | 1 | 1 | 23µs | 57µs | BEGIN@364 | String::Escape::
1 | 1 | 1 | 12µs | 14µs | BEGIN@9 | String::Escape::
1 | 1 | 1 | 10µs | 23µs | BEGIN@55 | String::Escape::
1 | 1 | 1 | 8µs | 30µs | BEGIN@13 | String::Escape::
1 | 1 | 1 | 8µs | 23µs | BEGIN@516 | String::Escape::
1 | 1 | 1 | 7µs | 36µs | BEGIN@11 | String::Escape::
1 | 1 | 1 | 7µs | 14µs | BEGIN@10 | String::Escape::
1 | 1 | 1 | 7µs | 33µs | BEGIN@182 | String::Escape::
1 | 1 | 1 | 6µs | 35µs | BEGIN@57 | String::Escape::
1 | 1 | 1 | 6µs | 32µs | BEGIN@255 | String::Escape::
0 | 0 | 0 | 0s | 0s | __ANON__[:584] | String::Escape::
0 | 0 | 0 | 0s | 0s | __ANON__[:586] | String::Escape::
0 | 0 | 0 | 0s | 0s | __ANON__[:587] | String::Escape::
0 | 0 | 0 | 0s | 0s | __ANON__[:588] | String::Escape::
0 | 0 | 0 | 0s | 0s | __ANON__[:606] | String::Escape::
0 | 0 | 0 | 0s | 0s | _expand_escape_spec | String::Escape::
0 | 0 | 0 | 0s | 0s | _unsupported_escape_spec | String::Escape::
0 | 0 | 0 | 0s | 0s | backslash | String::Escape::
0 | 0 | 0 | 0s | 0s | elide | String::Escape::
0 | 0 | 0 | 0s | 0s | escape | String::Escape::
0 | 0 | 0 | 0s | 0s | hash2list | String::Escape::
0 | 0 | 0 | 0s | 0s | hash2string | String::Escape::
0 | 0 | 0 | 0s | 0s | list2hash | String::Escape::
0 | 0 | 0 | 0s | 0s | list2string | String::Escape::
0 | 0 | 0 | 0s | 0s | names | String::Escape::
0 | 0 | 0 | 0s | 0s | printable | String::Escape::
0 | 0 | 0 | 0s | 0s | qprintable | String::Escape::
0 | 0 | 0 | 0s | 0s | qqbackslash | String::Escape::
0 | 0 | 0 | 0s | 0s | quote | String::Escape::
0 | 0 | 0 | 0s | 0s | quote_non_words | String::Escape::
0 | 0 | 0 | 0s | 0s | singlequote | String::Escape::
0 | 0 | 0 | 0s | 0s | string2hash | String::Escape::
0 | 0 | 0 | 0s | 0s | string2list | String::Escape::
0 | 0 | 0 | 0s | 0s | unbackslash | String::Escape::
0 | 0 | 0 | 0s | 0s | unprintable | String::Escape::
0 | 0 | 0 | 0s | 0s | unqprintable | String::Escape::
0 | 0 | 0 | 0s | 0s | unqqbackslash | String::Escape::
0 | 0 | 0 | 0s | 0s | unquote | String::Escape::
0 | 0 | 0 | 0s | 0s | unquotemeta | String::Escape::
0 | 0 | 0 | 0s | 0s | unsinglequote | String::Escape::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | =head1 NAME | ||||
2 | |||||
3 | String::Escape - Backslash escapes, quoted phrase, word elision, etc. | ||||
4 | |||||
5 | =cut | ||||
6 | |||||
7 | package String::Escape; | ||||
8 | |||||
9 | 3 | 17µs | 2 | 16µs | # spent 14µs (12+2) within String::Escape::BEGIN@9 which was called:
# once (12µs+2µs) by Devel::Backtrace::Point::BEGIN@6 at line 9 # spent 14µs making 1 call to String::Escape::BEGIN@9
# spent 2µs making 1 call to strict::import |
10 | 3 | 20µs | 2 | 22µs | # spent 14µs (7+7) within String::Escape::BEGIN@10 which was called:
# once (7µs+7µs) by Devel::Backtrace::Point::BEGIN@6 at line 10 # spent 14µs making 1 call to String::Escape::BEGIN@10
# spent 7µs making 1 call to warnings::import |
11 | 3 | 21µs | 2 | 64µs | # spent 36µs (7+28) within String::Escape::BEGIN@11 which was called:
# once (7µs+28µs) by Devel::Backtrace::Point::BEGIN@6 at line 11 # spent 36µs making 1 call to String::Escape::BEGIN@11
# spent 28µs making 1 call to Exporter::import |
12 | |||||
13 | 3 | 43µs | 2 | 52µs | # spent 30µs (8+22) within String::Escape::BEGIN@13 which was called:
# once (8µs+22µs) by Devel::Backtrace::Point::BEGIN@6 at line 13 # spent 30µs making 1 call to String::Escape::BEGIN@13
# spent 22µs making 1 call to vars::import |
14 | 1 | 600ns | $VERSION = 2010.002; | ||
15 | |||||
16 | ######################################################################## | ||||
17 | |||||
18 | =head1 SYNOPSIS | ||||
19 | |||||
20 | This module provides a flexible calling interface to some frequently-performed string conversion functions, including applying and removing backslash escapes like \n and \t, wrapping and removing double-quotes, and truncating to fit within a desired length. | ||||
21 | |||||
22 | use String::Escape qw( printable unprintable ); | ||||
23 | # Convert control, high-bit chars to \n or \xxx escapes | ||||
24 | $output = printable($value); | ||||
25 | # Convert escape sequences back to original chars | ||||
26 | $value = unprintable($input); | ||||
27 | |||||
28 | use String::Escape qw( elide ); | ||||
29 | # Shorten strings to fit, if necessary | ||||
30 | foreach (@_) { print elide( $_, 79 ) . "\n"; } | ||||
31 | |||||
32 | use String::Escape qw( string2list list2string ); | ||||
33 | # Pack and unpack simple lists by quoting each item | ||||
34 | $list = list2string( @list ); | ||||
35 | @list = string2list( $list ); | ||||
36 | |||||
37 | use String::Escape qw( escape ); | ||||
38 | # Defer selection of escaping routines until runtime | ||||
39 | $escape_name = $use_quotes ? 'qprintable' : 'printable'; | ||||
40 | @escaped = escape($escape_name, @values); | ||||
41 | |||||
42 | =cut | ||||
43 | |||||
44 | |||||
45 | ######################################################################## | ||||
46 | |||||
47 | =head1 INTERFACE | ||||
48 | |||||
49 | All of the public functions described below are available as optional exports. | ||||
50 | |||||
51 | You can either import the specific functions you want, or import only the C<escape()> function and pass it the names of the functions to invoke. | ||||
52 | |||||
53 | =cut | ||||
54 | |||||
55 | 3 | 21µs | 2 | 36µs | # spent 23µs (10+13) within String::Escape::BEGIN@55 which was called:
# once (10µs+13µs) by Devel::Backtrace::Point::BEGIN@6 at line 55 # spent 23µs making 1 call to String::Escape::BEGIN@55
# spent 13µs making 1 call to Exporter::import |
56 | |||||
57 | 3 | 218µs | 2 | 64µs | # spent 35µs (6+29) within String::Escape::BEGIN@57 which was called:
# once (6µs+29µs) by Devel::Backtrace::Point::BEGIN@6 at line 57 # spent 35µs making 1 call to String::Escape::BEGIN@57
# spent 29µs making 1 call to vars::import |
58 | |||||
59 | 1 | 10µs | push @ISA, qw( Exporter ); | ||
60 | 1 | 6µs | push @EXPORT_OK, qw( | ||
61 | quote unquote quote_non_words singlequote unsinglequote | ||||
62 | backslash unbackslash qqbackslash unqqbackslash | ||||
63 | printable unprintable qprintable unqprintable | ||||
64 | unquotemeta | ||||
65 | elide | ||||
66 | escape | ||||
67 | string2list string2hash list2string list2hash hash2string hash2list | ||||
68 | ); | ||||
69 | |||||
70 | |||||
71 | ######################################################################## | ||||
72 | |||||
73 | =head2 Quoting | ||||
74 | |||||
75 | Each of these functions takes a single simple scalar argument and | ||||
76 | returns its escaped (or unescaped) equivalent. | ||||
77 | |||||
78 | =over 4 | ||||
79 | |||||
80 | =item quote($value) : $escaped | ||||
81 | |||||
82 | Add double quote characters to each end of the string. | ||||
83 | |||||
84 | =item unquote($value) : $escaped | ||||
85 | |||||
86 | If the string both begins and ends with double quote characters, they are removed, otherwise the string is returned unchanged. | ||||
87 | |||||
88 | =item quote_non_words($value) : $escaped | ||||
89 | |||||
90 | As above, but only quotes empty, punctuated, and multiword values; simple values consisting of alphanumerics without special characters are not quoted. | ||||
91 | |||||
92 | =item singlequote($value) : $escaped | ||||
93 | |||||
94 | Add single quote characters to each end of the string. | ||||
95 | |||||
96 | =item unsinglequote($value) : $escaped | ||||
97 | |||||
98 | If the string both begins and ends with single quote characters, they are removed, otherwise the string is returned unchanged. | ||||
99 | |||||
100 | =back | ||||
101 | |||||
102 | =cut | ||||
103 | |||||
104 | # $with_surrounding_quotes = quote( $string_value ); | ||||
105 | sub quote ($) { | ||||
106 | '"' . $_[0] . '"' | ||||
107 | } | ||||
108 | |||||
109 | # $remove_surrounding_quotes = quote( $string_value ); | ||||
110 | sub unquote ($) { | ||||
111 | ( $_[0] =~ m/ \A ["] (.*) ["] \Z /sx ) ? $1 : $_[0]; | ||||
112 | } | ||||
113 | |||||
114 | # $word_or_phrase_with_surrounding_quotes = quote( $string_value ); | ||||
115 | sub quote_non_words ($) { | ||||
116 | ( ! length $_[0] or $_[0] =~ /[^\w\_\-\/\.\:\#]/ ) ? '"'.$_[0].'"' : $_[0] | ||||
117 | } | ||||
118 | |||||
119 | # $with_surrounding_quotes = singlequote( $string_value ); | ||||
120 | sub singlequote ($) { | ||||
121 | '\'' . $_[0] . '\'' | ||||
122 | } | ||||
123 | |||||
124 | # $remove_surrounding_quotes = singlequote( $string_value ); | ||||
125 | sub unsinglequote ($) { | ||||
126 | ( $_[0] =~ m/ \A ['] (.*) ['] \Z /sx ) ? $1 : $_[0]; | ||||
127 | } | ||||
128 | |||||
129 | |||||
130 | ######################################################################## | ||||
131 | |||||
132 | =head2 Backslash Escaping Functions | ||||
133 | |||||
134 | Each of these functions takes a single simple scalar argument and | ||||
135 | returns its escaped (or unescaped) equivalent. | ||||
136 | |||||
137 | These functions recognize common whitespace sequences C<\r>, C<\n>, and C<\t>, as well as hex escapes C<\x4F> and ocatal C<\020>. | ||||
138 | |||||
139 | When escaping, alphanumeric characters and most punctuation is passed through unchanged; only the return, newline, tab, backslash, dollar, at sign and unprintable control and high-bit characters are escaped. | ||||
140 | |||||
141 | =over 4 | ||||
142 | |||||
143 | =item backslash($value) : $escaped | ||||
144 | |||||
145 | Converts special characters to their backslash-escaped equivalents. | ||||
146 | |||||
147 | =item unbackslash($value) : $escaped | ||||
148 | |||||
149 | Converts backslash escape sequences in a string back to their original characters. | ||||
150 | |||||
151 | =item qqbackslash($value) : $escaped | ||||
152 | |||||
153 | Converts special characters to their backslash-escaped equivalents and then wraps the results with double quotes. | ||||
154 | |||||
155 | =item unqqbackslash($value) : $escaped | ||||
156 | |||||
157 | Strips surrounding double quotes then converts backslash escape sequences back to their original characters. | ||||
158 | |||||
159 | =back | ||||
160 | |||||
161 | Here are a few examples: | ||||
162 | |||||
163 | =over 4 | ||||
164 | |||||
165 | =item * | ||||
166 | |||||
167 | print backslash( "\tNow is the time\nfor all good folks\n" ); | ||||
168 | |||||
169 | \tNow is the time\nfor all good folks\n | ||||
170 | |||||
171 | =item * | ||||
172 | |||||
173 | print unbackslash( '\\tNow is the time\\nfor all good folks\\n' ); | ||||
174 | |||||
175 | Now is the time | ||||
176 | for all good folks | ||||
177 | |||||
178 | =back | ||||
179 | |||||
180 | =cut | ||||
181 | |||||
182 | 3 | 322µs | 2 | 59µs | # spent 33µs (7+26) within String::Escape::BEGIN@182 which was called:
# once (7µs+26µs) by Devel::Backtrace::Point::BEGIN@6 at line 182 # spent 33µs making 1 call to String::Escape::BEGIN@182
# spent 26µs making 1 call to vars::import |
183 | |||||
184 | # Earlier definitions are preferred to later ones, thus we output \n not \x0d | ||||
185 | _define_backslash_escapes( | ||||
186 | ( map { $_ => $_ } ( '\\', '"', '$', '@' ) ), | ||||
187 | ( 'r' => "\r", 'n' => "\n", 't' => "\t" ), | ||||
188 | ( map { 'x' . unpack('H2', chr($_)) => chr($_) } (0..255) ), | ||||
189 | 1 | 829µs | 257 | 874µs | ( map { sprintf('%03o', $_) => chr($_) } (0..255) ), # spent 739µs making 1 call to String::Escape::_define_backslash_escapes
# spent 135µs making 256 calls to String::Escape::CORE:unpack, avg 526ns/call |
190 | ); | ||||
191 | |||||
192 | # spent 739µs within String::Escape::_define_backslash_escapes which was called:
# once (739µs+0s) by Devel::Backtrace::Point::BEGIN@6 at line 189 | ||||
193 | 2 | 734µs | %Interpolated = @_; | ||
194 | %Backslashed = reverse @_; | ||||
195 | } | ||||
196 | |||||
197 | # $special_characters_escaped = backslash( $source_string ); | ||||
198 | sub backslash ($) { | ||||
199 | local $_ = ( defined $_[0] ? $_[0] : '' ); | ||||
200 | # Preserve only printable ASCII characters other than \, ", $, and @ | ||||
201 | s/([^\x20\x21\x24\x25-\x39\x41-\x5b\x5d-\x7e])/\\$Backslashed{$1}/gs; | ||||
202 | return $_; | ||||
203 | } | ||||
204 | |||||
205 | # $original_string = unbackslash( $special_characters_escaped ); | ||||
206 | sub unbackslash ($) { | ||||
207 | local $_ = ( defined $_[0] ? $_[0] : '' ); | ||||
208 | s/ (\A|\G|[^\\]) [\\] ( [0]\d\d | [x][\da-fA-F]{2} | . ) / $1 . ( $Interpolated{lc($2) }) /gsxe; | ||||
209 | return $_; | ||||
210 | } | ||||
211 | |||||
212 | # quoted_and_escaped = qqbackslash( $source_string ); | ||||
213 | sub qqbackslash ($) { quote backslash $_[0] } | ||||
214 | |||||
215 | # $original_string = unqqbackslash( quoted_and_escaped ); | ||||
216 | sub unqqbackslash ($) { unbackslash unquote $_[0] } | ||||
217 | |||||
218 | |||||
219 | ######################################################################## | ||||
220 | |||||
221 | =head2 Legacy Backslash Functions | ||||
222 | |||||
223 | In addition to the four functions listed above, there is a corresponding set which use a slightly different set of escape sequences. | ||||
224 | |||||
225 | These functions do not support as many escape sequences and use a non-standard | ||||
226 | format for hex escapes. In general, the above C<backslash()> functions are | ||||
227 | recommended, while these functions are retained for legacy compatibility | ||||
228 | purposes. | ||||
229 | |||||
230 | =over 4 | ||||
231 | |||||
232 | =item printable($value) : $escaped | ||||
233 | |||||
234 | Converts return, newline, tab, backslash and unprintable | ||||
235 | characters to their backslash-escaped equivalents. | ||||
236 | |||||
237 | =item unprintable($value) : $escaped | ||||
238 | |||||
239 | Converts backslash escape sequences in a string back to their original value. | ||||
240 | |||||
241 | =item qprintable($value) : $escaped | ||||
242 | |||||
243 | Converts special characters to their backslash-escaped equivalents and then wraps the results with double quotes. | ||||
244 | |||||
245 | (Note that this is I<not> MIME quoted-printable encoding.) | ||||
246 | |||||
247 | =item unqprintable($value) : $escaped | ||||
248 | |||||
249 | Strips surrounding double quotes then converts backslash escape sequences back to their original value. | ||||
250 | |||||
251 | =back | ||||
252 | |||||
253 | =cut | ||||
254 | |||||
255 | 3 | 296µs | 2 | 57µs | # spent 32µs (6+25) within String::Escape::BEGIN@255 which was called:
# once (6µs+25µs) by Devel::Backtrace::Point::BEGIN@6 at line 255 # spent 32µs making 1 call to String::Escape::BEGIN@255
# spent 25µs making 1 call to vars::import |
256 | %Printable = ( | ||||
257 | ( map { chr($_), unpack('H2', chr($_)) } (0..255) ), | ||||
258 | ( "\\"=>'\\', "\r"=>'r', "\n"=>'n', "\t"=>'t', ), | ||||
259 | 1 | 573µs | 256 | 83µs | ( map { $_ => $_ } ( '"' ) ) # spent 83µs making 256 calls to String::Escape::CORE:unpack, avg 323ns/call |
260 | ); | ||||
261 | 1 | 140µs | %Unprintable = ( reverse %Printable ); | ||
262 | |||||
263 | # $special_characters_escaped = printable( $source_string ); | ||||
264 | sub printable ($) { | ||||
265 | local $_ = ( defined $_[0] ? $_[0] : '' ); | ||||
266 | s/([\r\n\t\"\\\x00-\x1f\x7F-\xFF])/ '\\' . $Printable{$1} /gsxe; | ||||
267 | return $_; | ||||
268 | } | ||||
269 | |||||
270 | # $original_string = unprintable( $special_characters_escaped ); | ||||
271 | sub unprintable ($) { | ||||
272 | local $_ = ( defined $_[0] ? $_[0] : '' ); | ||||
273 | s/((?:\A|\G|[^\\]))\\([rRnNtT\"\\]|[x]?[\da-fA-F]{2})/ $1 . $Unprintable{lc($2)} /gsxe; | ||||
274 | return $_; | ||||
275 | } | ||||
276 | |||||
277 | # quoted_and_escaped = qprintable( $source_string ); | ||||
278 | sub qprintable ($) { quote_non_words printable $_[0] } | ||||
279 | |||||
280 | # $original_string = unqprintable( quoted_and_escaped ); | ||||
281 | sub unqprintable ($) { unprintable unquote $_[0] } | ||||
282 | |||||
283 | |||||
284 | ######################################################################## | ||||
285 | |||||
286 | =head2 Other Backslash Functions | ||||
287 | |||||
288 | In addition to the functions listed above, there is also one function that mirrors the behavior of Perl's built-in C<quotemeta()> function. | ||||
289 | |||||
290 | =over 4 | ||||
291 | |||||
292 | =item unquotemeta($value) : $escaped | ||||
293 | |||||
294 | Strips out backslashes before any character. | ||||
295 | |||||
296 | =back | ||||
297 | |||||
298 | =cut | ||||
299 | |||||
300 | sub unquotemeta ($) { | ||||
301 | local $_ = ( defined $_[0] ? $_[0] : '' ); | ||||
302 | s/ (\A|\G|[^\\]) [\\] (.) / $1 . $2 /gsex; | ||||
303 | return $_; | ||||
304 | } | ||||
305 | |||||
306 | |||||
307 | ######################################################################## | ||||
308 | |||||
309 | =head2 Elision Function | ||||
310 | |||||
311 | This function extracts the leading portion of a provided string and appends ellipsis if it's longer than the desired maximum excerpt length. | ||||
312 | |||||
313 | =over 4 | ||||
314 | |||||
315 | =item elide($string) : $elided_string | ||||
316 | |||||
317 | =item elide($string, $length) : $elided_string | ||||
318 | |||||
319 | =item elide($string, $length, $word_boundary_strictness) : $elided_string | ||||
320 | |||||
321 | =item elide($string, $length, $word_boundary_strictness, $elipses) : $elided_string | ||||
322 | |||||
323 | Return a single-quoted, shortened version of the string, with ellipsis. | ||||
324 | |||||
325 | If the original string is shorter than $length, it is returned unchanged. At most $length characters are returned; if called with a single argument, $length defaults to $DefaultLength. | ||||
326 | |||||
327 | Up to $word_boundary_strictness additional characters may be ommited in order to make the elided portion end on a word boundary; you can pass 0 to ignore word boundaries. If not provided, $word_boundary_strictness defaults to $DefaultStrictness. | ||||
328 | |||||
329 | =item $Elipses | ||||
330 | |||||
331 | The string of characters used to indicate the end of the excerpt. Initialized to '...'. | ||||
332 | |||||
333 | =item $DefaultLength | ||||
334 | |||||
335 | The default target excerpt length, used when the elide function is called with a single argument. Initialized to 60. | ||||
336 | |||||
337 | =item $DefaultStrictness | ||||
338 | |||||
339 | The default word-boundary flexibility, used when the elide function is called without the third argument. Initialized to 10. | ||||
340 | |||||
341 | =back | ||||
342 | |||||
343 | Here are a few examples: | ||||
344 | |||||
345 | =over 4 | ||||
346 | |||||
347 | =item * | ||||
348 | |||||
349 | $string = 'foo bar baz this that the other'; | ||||
350 | |||||
351 | print elide( $string, 12 ); | ||||
352 | # foo bar... | ||||
353 | |||||
354 | print elide( $string, 12, 0 ); | ||||
355 | # foo bar b... | ||||
356 | |||||
357 | print elide( $string, 100 ); | ||||
358 | # foo bar baz this that the other | ||||
359 | |||||
360 | =back | ||||
361 | |||||
362 | =cut | ||||
363 | |||||
364 | 3 | 178µs | 2 | 91µs | # spent 57µs (23+34) within String::Escape::BEGIN@364 which was called:
# once (23µs+34µs) by Devel::Backtrace::Point::BEGIN@6 at line 364 # spent 57µs making 1 call to String::Escape::BEGIN@364
# spent 34µs making 1 call to vars::import |
365 | 1 | 700ns | $Elipses = '...'; | ||
366 | 1 | 500ns | $DefaultLength = 60; | ||
367 | 1 | 500ns | $DefaultStrictness = 10; | ||
368 | |||||
369 | # $elided_string = elide($string); | ||||
370 | # $elided_string = elide($string, $length); | ||||
371 | # $elided_string = elide($string, $length, $word_boundary_strictness); | ||||
372 | # $elided_string = elide($string, $length, $word_boundary_strictness, $elipses); | ||||
373 | sub elide ($;$$) { | ||||
374 | my $source = shift; | ||||
375 | my $length = scalar(@_) ? shift() : $DefaultLength; | ||||
376 | my $word_limit = scalar(@_) ? shift() : $DefaultStrictness; | ||||
377 | my $elipses = scalar(@_) ? shift() : $Elipses; | ||||
378 | |||||
379 | # If the source is already short, we don't need to do anything | ||||
380 | return $source if (length($source) < $length); | ||||
381 | |||||
382 | # Leave room for the elipses and make sure we include at least one character. | ||||
383 | $length -= length( $elipses ); | ||||
384 | $length = 1 if ( $length < 1 ); | ||||
385 | |||||
386 | my $excerpt; | ||||
387 | |||||
388 | # Try matching $length characters or less at a word boundary. | ||||
389 | $excerpt = ( $source =~ /^(.{0,$length})(?:\s|\Z)/ )[0] if ( $word_limit ); | ||||
390 | |||||
391 | # If that fails or returns much less than we wanted, ignore boundaries | ||||
392 | $excerpt = substr($source, 0, $length) if ( | ||||
393 | ! defined $excerpt or | ||||
394 | length($excerpt) < length($source) and | ||||
395 | ! length($excerpt) || abs($length - length($excerpt)) > $word_limit | ||||
396 | ); | ||||
397 | |||||
398 | return $excerpt . $elipses; | ||||
399 | } | ||||
400 | |||||
401 | |||||
402 | ######################################################################## | ||||
403 | |||||
404 | =head2 escape() | ||||
405 | |||||
406 | These functions provide for the registration of string-escape specification | ||||
407 | names and corresponding functions, and then allow the invocation of one or | ||||
408 | several of these functions on one or several source string values. | ||||
409 | |||||
410 | =over 4 | ||||
411 | |||||
412 | =item escape($escapes, $value) : $escaped_value | ||||
413 | |||||
414 | =item escape($escapes, @values) : @escaped_values | ||||
415 | |||||
416 | Returns an altered copy of the provided values by looking up the escapes string in a registry of string-modification functions. | ||||
417 | |||||
418 | If called in a scalar context, operates on the single value passed in; if | ||||
419 | called in a list contact, operates identically on each of the provided values. | ||||
420 | |||||
421 | Space-separated compound specifications like 'quoted uppercase' are expanded to a list of functions to be applied in order. | ||||
422 | |||||
423 | Valid escape specifications are: | ||||
424 | |||||
425 | =over 4 | ||||
426 | |||||
427 | =item one of the keys defined in %Escapes | ||||
428 | |||||
429 | The coresponding specification will be looked up and used. | ||||
430 | |||||
431 | =item a sequence of names separated by whitespace, | ||||
432 | |||||
433 | Each name will be looked up, and each of the associated functions will be applied successively, from left to right. | ||||
434 | |||||
435 | =item a reference to a function | ||||
436 | |||||
437 | The provided function will be called on with each value in turn. | ||||
438 | |||||
439 | =item a reference to an array | ||||
440 | |||||
441 | Each item in the array will be expanded as provided above. | ||||
442 | |||||
443 | =back | ||||
444 | |||||
445 | A fatal error will be generated if you pass an unsupported escape specification, or if the function is called with multiple values in a scalar context. | ||||
446 | |||||
447 | =item String::Escape::names() : @defined_escapes | ||||
448 | |||||
449 | Returns a list of defined escape specification strings. | ||||
450 | |||||
451 | =item String::Escape::add( $escape_name, \&escape_function ); | ||||
452 | |||||
453 | Add a new escape specification and corresponding function. | ||||
454 | |||||
455 | =back | ||||
456 | |||||
457 | By default, all of the public functions described below are available as named escape commands, as well as the following built-in functions: | ||||
458 | |||||
459 | =over 4 | ||||
460 | |||||
461 | =item * | ||||
462 | |||||
463 | none: Return the string unchanged. | ||||
464 | |||||
465 | =item * | ||||
466 | |||||
467 | uppercase: Calls the built-in uc function. | ||||
468 | |||||
469 | =item * | ||||
470 | |||||
471 | lowercase: Calls the built-in lc function. | ||||
472 | |||||
473 | =item * | ||||
474 | |||||
475 | initialcase: Calls the built-in lc and ucfirst functions. | ||||
476 | |||||
477 | =back | ||||
478 | |||||
479 | Here are a few examples: | ||||
480 | |||||
481 | =over 4 | ||||
482 | |||||
483 | =item * | ||||
484 | |||||
485 | C<print escape('qprintable', "\tNow is the time\nfor all good folks\n" );> | ||||
486 | |||||
487 | "\tNow is the time\nfor all good folks\n" | ||||
488 | |||||
489 | =item * | ||||
490 | |||||
491 | C<print escape('uppercase qprintable', "\tNow is the time\nfor all good folks\n" );> | ||||
492 | |||||
493 | "\tNOW IS THE TIME\nFOR ALL GOOD FOLKS\n" | ||||
494 | |||||
495 | =item * | ||||
496 | |||||
497 | C<print join '--', escape('printable', "\tNow is the time\n", "for all good folks\n" );> | ||||
498 | |||||
499 | \tNow is the time\n--for all good folks\n | ||||
500 | |||||
501 | =item * | ||||
502 | |||||
503 | You can add more escaping functions to the supported set by calling add(). | ||||
504 | |||||
505 | C<String::Escape::add( 'html', \&HTML::Entities::encode_entities );> | ||||
506 | |||||
507 | C<print escape('html', "AT&T" );> | ||||
508 | |||||
509 | AT&T | ||||
510 | |||||
511 | =back | ||||
512 | |||||
513 | =cut | ||||
514 | |||||
515 | # %Escapes - escaper function references by name | ||||
516 | 3 | 786µs | 2 | 39µs | # spent 23µs (8+16) within String::Escape::BEGIN@516 which was called:
# once (8µs+16µs) by Devel::Backtrace::Point::BEGIN@6 at line 516 # spent 23µs making 1 call to String::Escape::BEGIN@516
# spent 16µs making 1 call to vars::import |
517 | |||||
518 | # String::Escape::add( $name, $subroutine ); | ||||
519 | # spent 30µs within String::Escape::add which was called:
# once (30µs+0s) by Devel::Backtrace::Point::BEGIN@6 at line 607 | ||||
520 | 41 | 32µs | while ( @_ ) { | ||
521 | my ( $name, $func ) = ( shift, shift ); | ||||
522 | $Escapes{ $name } = $func | ||||
523 | } | ||||
524 | } | ||||
525 | |||||
526 | # @defined_names = String::Escape::names(); | ||||
527 | sub names { | ||||
528 | keys(%Escapes) | ||||
529 | } | ||||
530 | |||||
531 | # $escaped = escape($escape_spec, $value); | ||||
532 | # @escaped = escape($escape_spec, @values); | ||||
533 | sub escape { | ||||
534 | my ($escape_spec, @values) = @_; | ||||
535 | |||||
536 | my @escapes = _expand_escape_spec($escape_spec); | ||||
537 | |||||
538 | foreach my $value ( @values ) { | ||||
539 | foreach my $escaper ( @escapes ) { | ||||
540 | $value = &$escaper( $value ); | ||||
541 | } | ||||
542 | } | ||||
543 | |||||
544 | if ( wantarray ) { | ||||
545 | @values | ||||
546 | } elsif ( @values > 1 ) { | ||||
547 | croak "escape called with multiple values but in scalar context" | ||||
548 | } else { | ||||
549 | $values[0] | ||||
550 | } | ||||
551 | } | ||||
552 | |||||
553 | # @escape_functions = _expand_escape_spec($escape_spec); | ||||
554 | sub _expand_escape_spec { | ||||
555 | my $escape_spec = shift; | ||||
556 | |||||
557 | if ( ref($escape_spec) eq 'CODE' ) { | ||||
558 | return $escape_spec; | ||||
559 | } elsif ( ref($escape_spec) eq 'ARRAY' ) { | ||||
560 | return map { _expand_escape_spec($_) } @$escape_spec; | ||||
561 | } elsif ( ! ref($escape_spec) ) { | ||||
562 | return map { | ||||
563 | _expand_escape_spec($_) | ||||
564 | } map { | ||||
565 | $Escapes{$_} or _unsupported_escape_spec( $_ ) | ||||
566 | } split(/\s+/, $escape_spec); | ||||
567 | } else { | ||||
568 | _unsupported_escape_spec( $escape_spec ); | ||||
569 | } | ||||
570 | } | ||||
571 | |||||
572 | # _unsupported_escape_spec($escape_spec); | ||||
573 | sub _unsupported_escape_spec { | ||||
574 | my $escape_spec = shift; | ||||
575 | |||||
576 | croak( | ||||
577 | "unsupported escape specification " . | ||||
578 | ( defined($escape_spec) ? "'$_'" : 'undef' ) . "; " . | ||||
579 | "should be one of " . join(', ', names()) | ||||
580 | ) | ||||
581 | } | ||||
582 | |||||
583 | add( | ||||
584 | 'none' => sub ($) { $_[0]; }, | ||||
585 | |||||
586 | 'uppercase' => sub ($) { uc $_[0] }, | ||||
587 | 'lowercase' => sub ($) { lc $_[0] }, | ||||
588 | 'initialcase' => sub ($) { ucfirst lc $_[0] }, | ||||
589 | |||||
590 | 'quote' => \"e, | ||||
591 | 'unquote' => \&unquote, | ||||
592 | 'quote_non_words' => \"e_non_words, | ||||
593 | 'singlequote' => \&singlequote, | ||||
594 | 'unsinglequote' => \&unsinglequote, | ||||
595 | |||||
596 | 'backslash' => \&backslash, | ||||
597 | 'unbackslash' => \&unbackslash, | ||||
598 | 'qqbackslash' => \&qqbackslash, #b | ||||
599 | 'unqqbackslash' => \&unqqbackslash, | ||||
600 | |||||
601 | 'printable' => \&printable, | ||||
602 | 'unprintable' => \&unprintable, | ||||
603 | 'qprintable' => \&qprintable, | ||||
604 | 'unqprintable' => \&unqprintable, | ||||
605 | |||||
606 | 'quotemeta' => sub ($) { quotemeta $_[0] }, | ||||
607 | 1 | 19µs | 1 | 30µs | 'unquotemeta' => \&unquotemeta, # spent 30µs making 1 call to String::Escape::add |
608 | |||||
609 | 'elide' => \&elide, | ||||
610 | ); | ||||
611 | |||||
612 | |||||
613 | ######################################################################## | ||||
614 | |||||
615 | =head2 Space-separated Lists and Hashes | ||||
616 | |||||
617 | =over 4 | ||||
618 | |||||
619 | =item @words = string2list( $space_separated_phrases ); | ||||
620 | |||||
621 | Converts a space separated string of words and quoted phrases to an array; | ||||
622 | |||||
623 | =item $space_sparated_string = list2string( @words ); | ||||
624 | |||||
625 | Joins an array of strings into a space separated string of words and quoted phrases; | ||||
626 | |||||
627 | =item %hash = string2hash( $string ); | ||||
628 | |||||
629 | Converts a space separated string of equal-sign-associated key=value pairs into a simple hash. | ||||
630 | |||||
631 | =item $string = hash2string( %hash ); | ||||
632 | |||||
633 | Converts a simple hash into a space separated string of equal-sign-associated key=value pairs. | ||||
634 | |||||
635 | =item %hash = list2hash( @words ); | ||||
636 | |||||
637 | Converts an array of equal-sign-associated key=value strings into a simple hash. | ||||
638 | |||||
639 | =item @words = hash2list( %hash ); | ||||
640 | |||||
641 | Converts a hash to an array of equal-sign-associated key=value strings. | ||||
642 | |||||
643 | =back | ||||
644 | |||||
645 | Here are a few examples: | ||||
646 | |||||
647 | =over 4 | ||||
648 | |||||
649 | =item * | ||||
650 | |||||
651 | C<print list2string('hello', 'I move next march');> | ||||
652 | |||||
653 | hello "I move next march" | ||||
654 | |||||
655 | =item * | ||||
656 | |||||
657 | C<@list = string2list('one "second item" 3 "four\nlines\nof\ntext"');> | ||||
658 | |||||
659 | C<print $list[1];> | ||||
660 | |||||
661 | second item | ||||
662 | |||||
663 | =item * | ||||
664 | |||||
665 | C<print hash2string( 'foo' =E<gt> 'Animal Cities', 'bar' =E<gt> 'Cheap' );> | ||||
666 | |||||
667 | foo="Animal Cities" bar=Cheap | ||||
668 | |||||
669 | =item * | ||||
670 | |||||
671 | C<%hash = string2hash('key=value "undefined key" words="the cat in the hat"');> | ||||
672 | |||||
673 | C<print $hash{'words'};> | ||||
674 | |||||
675 | the cat in the hat | ||||
676 | |||||
677 | C<print exists $hash{'undefined_key'} and ! defined $hash{'undefined_key'};> | ||||
678 | |||||
679 | 1 | ||||
680 | |||||
681 | =back | ||||
682 | |||||
683 | =cut | ||||
684 | |||||
685 | # @words = string2list( $space_separated_phrases ); | ||||
686 | sub string2list { | ||||
687 | my $text = shift; | ||||
688 | |||||
689 | carp "string2list called with a non-text argument, '$text'" if (ref $text); | ||||
690 | |||||
691 | my @words; | ||||
692 | my $word = ''; | ||||
693 | |||||
694 | while ( length $text ) { | ||||
695 | if ($text =~ s/\A(?: ([^\"\s\\]+) | \\(.) )//mx) { | ||||
696 | $word .= $1; | ||||
697 | } elsif ($text =~ s/\A"((?:[^\"\\]|\\.)*)"//mx) { | ||||
698 | $word .= $1; | ||||
699 | } elsif ($text =~ s/\A\s+//m){ | ||||
700 | push(@words, unprintable($word)); | ||||
701 | $word = ''; | ||||
702 | } elsif ($text =~ s/\A"//) { | ||||
703 | carp "string2list found an unmatched quote at '$text'"; | ||||
704 | return; | ||||
705 | } else { | ||||
706 | carp "string2list parse exception at '$text'"; | ||||
707 | return; | ||||
708 | } | ||||
709 | } | ||||
710 | push(@words, unprintable($word)); | ||||
711 | |||||
712 | return @words; | ||||
713 | } | ||||
714 | |||||
715 | # $space_sparated_string = list2string( @words ); | ||||
716 | sub list2string { | ||||
717 | join ( ' ', map qprintable($_), @_ ); | ||||
718 | } | ||||
719 | |||||
720 | # %hash = list2hash( @words ); | ||||
721 | sub list2hash { | ||||
722 | my @pairs; | ||||
723 | foreach (@_) { | ||||
724 | my ($key, $val) = m/\A(.*?)(?:\=(.*))?\Z/s; | ||||
725 | push @pairs, $key, $val; | ||||
726 | } | ||||
727 | return @pairs; | ||||
728 | } | ||||
729 | |||||
730 | # @words = hash2list( %hash ); | ||||
731 | sub hash2list { | ||||
732 | my @words; | ||||
733 | while ( scalar @_ ) { | ||||
734 | my ($key, $value) = ( shift, shift ); | ||||
735 | push @words, qprintable($key) . '=' . qprintable($value) | ||||
736 | } | ||||
737 | return @words; | ||||
738 | } | ||||
739 | |||||
740 | # %hash = string2hash( $string ); | ||||
741 | sub string2hash { | ||||
742 | return list2hash( string2list( shift ) ); | ||||
743 | } | ||||
744 | |||||
745 | # $string = hash2string( %hash ); | ||||
746 | sub hash2string { | ||||
747 | join ( ' ', hash2list( @_ ) ); | ||||
748 | } | ||||
749 | |||||
750 | |||||
751 | ######################################################################## | ||||
752 | |||||
753 | =head1 SEE ALSO | ||||
754 | |||||
755 | Numerous modules provide collections of string escaping functions for specific contexts. | ||||
756 | |||||
757 | The string2list function is similar to to the quotewords function in the standard distribution; see L<Text::ParseWords>. | ||||
758 | |||||
759 | Use other packages to stringify more complex data structures; see L<Storable>, L<Data::Dumper>, or other similar package. | ||||
760 | |||||
761 | =cut | ||||
762 | |||||
763 | |||||
764 | ######################################################################## | ||||
765 | |||||
766 | |||||
767 | =head1 BUGS | ||||
768 | |||||
769 | The following issues or changes are under consideration for future releases: | ||||
770 | |||||
771 | =over 4 | ||||
772 | |||||
773 | =item * | ||||
774 | |||||
775 | Does this problem with the \r character only show up on Windows? (And is it, in fact, a feature rather than a bug?) | ||||
776 | |||||
777 | http://rt.cpan.org/Public/Bug/Display.html?id=19766 | ||||
778 | |||||
779 | =item * | ||||
780 | |||||
781 | Consider changes to word parsing in string2list: Perhaps use \b word-boundary test in elide's regular expression rather than \s|\Z? Perhaps quotes embedded in a word (eg: a@"!a) shouldn't cause phrase breaks? | ||||
782 | |||||
783 | =item * | ||||
784 | |||||
785 | Check for possible problems in the use of printable escaping functions and list2hash. For example, are the encoded strings for hashes with high-bit characters in their keys properly unquoted and unescaped? | ||||
786 | |||||
787 | =item * | ||||
788 | |||||
789 | We should allow escape specifications to contain = signs and optional arguments, so that users can request certain string lengths with C<escape("lowercase elide=20 quoted", @_>. | ||||
790 | |||||
791 | =back | ||||
792 | |||||
793 | |||||
794 | =head1 VERSION | ||||
795 | |||||
796 | This is version 2010.002. | ||||
797 | |||||
798 | |||||
799 | =head1 INSTALLATION | ||||
800 | |||||
801 | This package should run on any standard Perl 5 installation. | ||||
802 | |||||
803 | To install this package, download the distribution from a CPAN mirror, | ||||
804 | unpack the archive file, and execute the standard "perl Makefile.PL", | ||||
805 | "make test", "make install" sequence or your local equivalent. | ||||
806 | |||||
807 | |||||
808 | =head1 SUPPORT | ||||
809 | |||||
810 | Once installed, this module's documentation is available as a | ||||
811 | manual page via C<perldoc String::Escape> or on CPAN sites | ||||
812 | such as C<http://search.cpan.org/dist/String-Escape>. | ||||
813 | |||||
814 | If you have questions or feedback about this module, please feel free to | ||||
815 | contact the author at the address shown below. Although there is no formal | ||||
816 | support program, I do attempt to answer email promptly. Bug reports that | ||||
817 | contain a failing test case are greatly appreciated, and suggested patches | ||||
818 | will be promptly considered for inclusion in future releases. | ||||
819 | |||||
820 | You can report bugs and request features via the CPAN web tracking system | ||||
821 | at C<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=String-Escape> or by | ||||
822 | sending mail to C<bug-string-escape at rt.cpan.org>. | ||||
823 | |||||
824 | If you've found this module useful or have feedback about your | ||||
825 | experience with it, consider sharing your opinion with other Perl users | ||||
826 | by posting your comment to CPAN's ratings system | ||||
827 | (C<http://cpanratings.perl.org/rate/?distribution=String-Escape>). | ||||
828 | |||||
829 | For more general discussion, you may wish to post a message on PerlMonks | ||||
830 | (C<http://perlmonks.org/?node=Seekers%20of%20Perl%20Wisdom>) or on the | ||||
831 | comp.lang.perl.misc newsgroup | ||||
832 | (C<http://groups.google.com/group/comp.lang.perl.misc/topics>). | ||||
833 | |||||
- - | |||||
836 | =head1 AUTHOR | ||||
837 | |||||
838 | Matthew Simon Cavalletto, C<< <simonm at cavalletto.org> >> | ||||
839 | |||||
840 | Initial versions developed at Evolution Online Systems with Eleanor J. Evans and Jeremy G. Bishop. | ||||
841 | |||||
842 | |||||
843 | =head1 LICENSE | ||||
844 | |||||
845 | Copyright 2010, 2002 Matthew Simon Cavalletto. | ||||
846 | |||||
847 | Portions copyright 1996, 1997, 1998, 2001 Evolution Online Systems, Inc. | ||||
848 | |||||
849 | You may use, modify, and distribute this software under the same terms as Perl. | ||||
850 | |||||
851 | See http://dev.perl.org/licenses/ for more information. | ||||
852 | |||||
853 | |||||
854 | =cut | ||||
855 | |||||
856 | ######################################################################## | ||||
857 | |||||
858 | 1 | 44µs | 1; # End of String::Escape | ||
sub String::Escape::CORE:unpack; # opcode |