File: | lib/Message/String.pm |
Coverage: | 95.1% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | 1 1 1 1 1 1 | 2 1 20 12 3 26 | use strict; | ||||
2 | 1 1 1 1 1 1 | 2 1 25 2 0 29 | use warnings; | ||||
3 | |||||||
4 | package Message::String; | ||||||
5 | # VERSION | ||||||
6 | # ABSTRACT: A pragma to declare and organise messaging. | ||||||
7 | 2 2 2 | 315 3064 68 | use Clone ( 'clone' ); | ||||
8 | 2 2 2 | 894 161143 45 | use DateTime (); | ||||
9 | 2 2 2 | 8 0 116 | use List::MoreUtils ( 'distinct' ); | ||||
10 | 2 2 2 | 5 0 62 | use Scalar::Util ( 'reftype' ); | ||||
11 | 2 2 2 | 361 397 71 | use Sub::Util ( 'set_subname' ); | ||||
12 | 2 2 2 | 173 3713 8 | use Syntax::Feature::Void; | ||||
13 | 2 2 2 | 2090 3014 95 | use Term::ReadKey; | ||||
14 | 2 2 2 | 437 13414 7 | use namespace::clean; | ||||
15 | 2 2 2 | 443 2 16 | use overload ( fallback => 1, '""' => 'to_string' ); | ||||
16 | |||||||
17 | BEGIN { | ||||||
18 | # Set up "messages" pragma as a "Message::String" alias. | ||||||
19 | 2 | 30808 | *message:: = *Message::String::; | ||||
20 | |||||||
21 | # ... and prevent Perl from having a hissy-fit the first time | ||||||
22 | # a "use messages ..." directive is encountered. | ||||||
23 | 2 2 | 6 6 | $INC{'message.pm'} = "(set by @{[__PACKAGE__]})"; | ||||
24 | |||||||
25 | # We're eating-our-own-dog-food at the end of this module, but we | ||||||
26 | # will still need these three subroutines declaring before we can | ||||||
27 | # use them. | ||||||
28 | sub C_EXPECT_HAREF_OR_KVPL; | ||||||
29 | sub C_BAD_MESSAGE_ID; | ||||||
30 | sub C_MISSING_TEMPLATE; | ||||||
31 | |||||||
32 | # Messages come in eight basic flavours (or types): | ||||||
33 | # | ||||||
34 | # A (Severity 1: Alert) | ||||||
35 | # C (Severity 2: Critical) | ||||||
36 | # E (Severity 3: Error) | ||||||
37 | # W (Severity 4: Warning) | ||||||
38 | # N (Severity 5: Notice) | ||||||
39 | # I (Severity 6: Info) | ||||||
40 | # D (Severity 7: Diagnostic, or Debug) | ||||||
41 | # R (Severity 1: Response, or Prompt) | ||||||
42 | # M (Severity 6: Other, or Miscellaneous) | ||||||
43 | # | ||||||
44 | # Listed in that order for no other reason than it spells DINOCREW, | ||||||
45 | # which is kind of sad but easy to remember. Messages are handled | ||||||
46 | # in different ways and according to type and some of the more | ||||||
47 | # important type characteristics are defined in this table: | ||||||
48 | # | ||||||
49 | # level | ||||||
50 | # The verbosity or severity level. By default these align with | ||||||
51 | # syslog message levels, with the exception of package-spefic | ||||||
52 | # types 'M' and 'R'. | ||||||
53 | # timestamp | ||||||
54 | # Embed a timestamp in formatted message. May be '0' (No - default), | ||||||
55 | # '1' (Yes, using default "strftime" format), or a custom "strftime" | ||||||
56 | # format string. | ||||||
57 | # tlc | ||||||
58 | # Nothing quite as nice as Tender Love and Care, but the three-letter | ||||||
59 | # code that can be embedded in the formatted message (e.g. 'NTC' | ||||||
60 | # would, by default, be rendered as '*NTC*'). | ||||||
61 | # id | ||||||
62 | # A boolean determining whether or not the message identifer is | ||||||
63 | # embedded withing the text of the formatted message. | ||||||
64 | # issue | ||||||
65 | # A reference to the method that the issuer will use to get the | ||||||
66 | # rendered message out into the cold light of day. | ||||||
67 | # aliases | ||||||
68 | # A reference to a list of longer codes that the message constructor | ||||||
69 | # will fallback to when attempting to discern the message's type from | ||||||
70 | # its identifier. It first tries to determine if the message id is | ||||||
71 | # suffixed by a type code following a dash, digit or underscore. Then | ||||||
72 | # it checks for a type code followed by a dash, digit, or underscore. | ||||||
73 | # If neith of those checks is conclusive, it then checks to see if the | ||||||
74 | # id ends or begins with one of the type aliases listed in this table, | ||||||
75 | # and if that is also inconclisove then 'M' (Other) is assumed. | ||||||
76 | #<<< | ||||||
77 | 2 | 46 | my $types = { | ||||
78 | A => { | ||||||
79 | level => 1, timestamp => 0, tlc => '', id => 1, | ||||||
80 | issue => \&_alert, | ||||||
81 | aliases => [qw/ALT ALR ALERT/] | ||||||
82 | }, | ||||||
83 | C => { | ||||||
84 | level => 2, timestamp => 0, tlc => '', id => 1, | ||||||
85 | issue => \&_crit, | ||||||
86 | aliases => [qw/CRT CRITICAL CRIT FATAL FTL/] | ||||||
87 | }, | ||||||
88 | E => { | ||||||
89 | level => 3, timestamp => 0, tlc => '', id => 0, | ||||||
90 | issue => \&_err, | ||||||
91 | aliases => [qw/ERR ERROR/] | ||||||
92 | }, | ||||||
93 | W => { | ||||||
94 | level => 4, timestamp => 0, tlc => '', id => 0, | ||||||
95 | issue => \&_warning, | ||||||
96 | aliases => [qw/WRN WARNING WNG WARN/] | ||||||
97 | }, | ||||||
98 | N => { | ||||||
99 | level => 5, timestamp => 0, tlc => '', id => 0, | ||||||
100 | issue => \&_notice, | ||||||
101 | aliases => [qw/NTC NOTICE NOT/] | ||||||
102 | }, | ||||||
103 | I => { | ||||||
104 | level => 6, timestamp => 0, tlc => '', id => 0, | ||||||
105 | issue => \&_info, | ||||||
106 | aliases => [qw/INF INFO/] | ||||||
107 | }, | ||||||
108 | D => { | ||||||
109 | level => 7, timestamp => 0, tlc => '', id => 0, | ||||||
110 | issue => \&_diagnostic, | ||||||
111 | aliases => [qw/DEB DEBUG DGN DIAGNOSTIC/] | ||||||
112 | }, | ||||||
113 | R => { | ||||||
114 | level => 1, timestamp => 0, tlc => '', id => 0, | ||||||
115 | issue => \&_prompt, | ||||||
116 | aliases => [qw/RSP RESPONSE RES PROMPT PRM INPUT INP/] | ||||||
117 | }, | ||||||
118 | M => { | ||||||
119 | level => 6, timestamp => 0, tlc => '', id => 0, | ||||||
120 | issue => \&_other, | ||||||
121 | aliases => [qw/MSG MESSAGE OTHER MISC OTH OTR MSC/] | ||||||
122 | }, | ||||||
123 | }; | ||||||
124 | #>>> | ||||||
125 | |||||||
126 | # _initial_types | ||||||
127 | # In list context, returns the initial list of message type codes | ||||||
128 | # as an array. | ||||||
129 | # In scalar context, returns the initial list of message type codes | ||||||
130 | # as a string suitable for use in a Regex character class ([...]). | ||||||
131 | 2 40 | 8 20 | my @base_types = sort { $a cmp $b } keys %$types; | ||||
132 | 2 | 4 | my $base_types = join '', @base_types; | ||||
133 | |||||||
134 | sub _initial_types | ||||||
135 | { | ||||||
136 | 2 | 8 | return wantarray ? @base_types : $base_types; | ||||
137 | } | ||||||
138 | |||||||
139 | # _types | ||||||
140 | # Some of our methods require access to data presented in the message | ||||||
141 | # types table, defined above (see "$types"), either to manipulate it | ||||||
142 | # or simply to use the values. Many of these methods may be used as | ||||||
143 | # class and instance methods ('_type_level', '_type_id', to name two | ||||||
144 | # of them). Most of the time, this table is the single source of | ||||||
145 | # truth, that is unless AN INSTANCE attempts to use one of those | ||||||
146 | # methods to modifiy the data. Under those specific circumstances, | ||||||
147 | #Â the the message instance's gets its own copy of the type table | ||||||
148 | # loaded into its 'types' attribute before being modified -- | ||||||
149 | # copy on write semantics, if you will -- and that data, not the global | ||||||
150 | # data, is used by that instance. That local data is purged if the | ||||||
151 | # instance ever changes its message type. It is the job of this method | ||||||
152 | # to copy (if required) the data required by an instance and/or return | ||||||
153 | # that data as an instance's view of its context, or to return the a | ||||||
154 | # reference to the global data. | ||||||
155 | sub _types | ||||||
156 | { | ||||||
157 | 376 | 211 | my ( $invocant, $bool_copy ) = @_; | ||||
158 | 376 | 382 | return $types unless ref $invocant; | ||||
159 | 279 | 877 | return $types unless $bool_copy || exists $invocant->{types}; | ||||
160 | 27 | 202 | $invocant->{types} = clone( $types ) | ||||
161 | unless exists $invocant->{types}; | ||||||
162 | 27 | 30 | return $invocant->{types}; | ||||
163 | } | ||||||
164 | |||||||
165 | # _reset | ||||||
166 | # If called as an instance method, restores the instance to a reasonably | ||||||
167 | # pristine state. | ||||||
168 | # If called as a class method, restores the global type data to its | ||||||
169 | # pristine state. | ||||||
170 | 2 | 193 | my $types_backup = clone( $types ); | ||||
171 | |||||||
172 | sub _reset | ||||||
173 | { | ||||||
174 | 4 | 6 | my ( $invocant ) = @_; | ||||
175 | 4 | 7 | if ( ref $invocant ) { | ||||
176 | 2 | 5 | for my $key ( keys %$invocant ) { | ||||
177 | 13 | 48 | delete $invocant->{$key} | ||||
178 | unless $key =~ m{^(?:template|level|type|id)$}; | ||||||
179 | 13 | 10 | my $type = $invocant->type; | ||||
180 | 13 | 37 | $type = 'M' | ||||
181 | unless defined( $type ) && exists $types->{$type}; | ||||||
182 | 13 | 14 | $invocant->level( $types->{$type}{level} ); | ||||
183 | } | ||||||
184 | } | ||||||
185 | else { | ||||||
186 | 2 | 187 | $types = clone( $types_backup ); | ||||
187 | } | ||||||
188 | 4 | 21 | return $invocant; | ||||
189 | } | ||||||
190 | |||||||
191 | # _message_types | ||||||
192 | # In list context, returns the current list of message type codes | ||||||
193 | # as an array. | ||||||
194 | # In scalar context, returns the current list of message type codes | ||||||
195 | # as a string suitable for use in a Regex character class ([...]). | ||||||
196 | sub _message_types | ||||||
197 | { | ||||||
198 | 32 | 18 | my ( $invocant ) = @_; | ||||
199 | 32 | 34 | my $types = $invocant->_types; | ||||
200 | 32 652 | 72 293 | my @types = sort { $a cmp $b } keys %$types; | ||||
201 | return @types | ||||||
202 | 32 | 44 | if wantarray; | ||||
203 | 31 | 62 | return join '', @types; | ||||
204 | } | ||||||
205 | |||||||
206 | # _type_level | ||||||
207 | # Inspect or change the "level" setting (verbosity level) for a | ||||||
208 | # message type. | ||||||
209 | # * Be careful when calling this as an instance method as copy-on- | ||||||
210 | # write semantics come into play (see "_types" for more information). | ||||||
211 | sub _type_level | ||||||
212 | { | ||||||
213 | 69 | 58 | my ( $invocant, $type, $value ) = @_; | ||||
214 | 69 | 227 | if ( @_ > 1 && defined( $type ) ) { | ||||
215 | 67 | 77 | my $types = $invocant->_types( @_ > 2 ); | ||||
216 | 67 | 51 | $type = uc( $type ); | ||||
217 | 67 | 78 | if ( @_ > 2 ) { | ||||
218 | 7 | 28 | return $invocant | ||||
219 | if !ref( $invocant ) && $type =~ m{^[ACEW]$}; | ||||||
220 | 3 | 11 | $types->{$type}{level} | ||||
221 | = ( 0 + $value ) || $types->{$type}{level}; | ||||||
222 | 3 | 4 | $invocant->level( $types->{ $invocant->{type} }{level} ) | ||||
223 | if ref $invocant; | ||||||
224 | 3 | 4 | return $invocant; | ||||
225 | } | ||||||
226 | 60 | 122 | return $types->{$type}{level} | ||||
227 | if exists $types->{$type}; | ||||||
228 | } | ||||||
229 | 3 | 5 | return undef; | ||||
230 | } | ||||||
231 | |||||||
232 | # _type_id | ||||||
233 | # Inspect or change the "id" setting (whether the id appears in the | ||||||
234 | # formatted text) for a message type. | ||||||
235 | # * Be careful when calling this as an instance method as copy-on- | ||||||
236 | # write semantics come into play (see "_types" for more information). | ||||||
237 | sub _type_id | ||||||
238 | { | ||||||
239 | 87 | 63 | my ( $invocant, $type, $value ) = @_; | ||||
240 | 87 | 261 | if ( @_ > 1 && defined( $type ) ) { | ||||
241 | 85 | 78 | my $types = $invocant->_types( @_ > 2 ); | ||||
242 | 85 | 62 | $type = uc( $type ); | ||||
243 | 85 | 86 | if ( @_ > 2 ) { | ||||
244 | 2 | 3 | $types->{$type}{id} = !!$value; | ||||
245 | 2 | 3 | return $invocant; | ||||
246 | } | ||||||
247 | 83 | 339 | if ( $type eq '1' || $type eq '0' || $type eq '' ) { | ||||
248 | 3 | 18 | $types->{$_}{id} = !!$type for keys %$types; | ||||
249 | 3 | 4 | return $invocant; | ||||
250 | } | ||||||
251 | 80 | 184 | return $types->{$type}{id} | ||||
252 | if exists $types->{$type}; | ||||||
253 | } | ||||||
254 | 3 | 5 | return undef; | ||||
255 | } | ||||||
256 | |||||||
257 | # _type_timestamp | ||||||
258 | # Inspect or change the "timestamp" setting (whether and how the time | ||||||
259 | # appears in the formatted text) for a message type. | ||||||
260 | # * Be careful when calling this as an instance method as copy-on- | ||||||
261 | # write semantics come into play (see "_types" for more information). | ||||||
262 | sub _type_timestamp | ||||||
263 | { | ||||||
264 | 70 | 58 | my ( $invocant, $type, $value ) = @_; | ||||
265 | 70 | 268 | if ( @_ > 1 && defined( $type ) ) { | ||||
266 | 68 | 75 | my $types = $invocant->_types( @_ > 2 ); | ||||
267 | 68 | 57 | $type = uc( $type ); | ||||
268 | 68 | 68 | if ( @_ > 2 ) { | ||||
269 | 5 | 13 | $types->{$type}{timestamp} = $value || ''; | ||||
270 | 5 | 5 | return $invocant; | ||||
271 | } | ||||||
272 | 63 | 311 | if ( $type eq '1' || $type eq '0' || $type eq '' ) { | ||||
273 | 3 | 16 | $types->{$_}{timestamp} = $type for keys %$types; | ||||
274 | 3 | 4 | return $invocant; | ||||
275 | } | ||||||
276 | 60 | 151 | return $types->{$type}{timestamp} | ||||
277 | if exists $types->{$type}; | ||||||
278 | } | ||||||
279 | 3 | 5 | return undef; | ||||
280 | } | ||||||
281 | |||||||
282 | # _type_tlc | ||||||
283 | # Inspect or change the "tlc" setting (whether and what three-letter code | ||||||
284 | # appears in the formatted text) for a message type. | ||||||
285 | # * Be careful when calling this as an instance method as copy-on- | ||||||
286 | # write semantics come into play (see "_types" for more information). | ||||||
287 | sub _type_tlc | ||||||
288 | { | ||||||
289 | 67 | 46 | my ( $invocant, $type, $value ) = @_; | ||||
290 | 67 | 191 | if ( @_ > 1 && defined( $type ) ) { | ||||
291 | 65 | 55 | my $types = $invocant->_types( @_ > 2 ); | ||||
292 | 65 | 49 | $type = uc( $type ); | ||||
293 | 65 | 64 | if ( @_ > 2 ) { | ||||
294 | 3 | 4 | $value ||= ''; | ||||
295 | 3 | 6 | $value = substr( $value, 0, 3 ) | ||||
296 | if length( $value ) > 3; | ||||||
297 | 3 | 2 | $types->{$type}{tlc} = $value; | ||||
298 | 3 | 3 | return $invocant; | ||||
299 | } | ||||||
300 | 62 | 155 | return $types->{$type}{tlc} | ||||
301 | if exists $types->{$type}; | ||||||
302 | } | ||||||
303 | 3 | 5 | return undef; | ||||
304 | } | ||||||
305 | |||||||
306 | # _type_aliases | ||||||
307 | # Inspect or change the "aleiases" setting for a message type. | ||||||
308 | # * Be careful when calling this as an instance method as copy-on- | ||||||
309 | # write semantics come into play (see "_types" for more information). | ||||||
310 | sub _type_aliases | ||||||
311 | { | ||||||
312 | 12 | 10 | my ( $invocant, $type, $value ) = @_; | ||||
313 | 12 | 39 | if ( @_ > 1 && defined( $type ) ) { | ||||
314 | 9 | 9 | my $types = $invocant->_types( @_ > 2 ); | ||||
315 | 9 | 5 | $type = uc( $type ); | ||||
316 | 9 | 9 | if ( @_ > 2 ) { | ||||
317 | 3 | 3 | my $tlc = $invocant->_type_tlc( $type ); | ||||
318 | 3 | 10 | $value = [] | ||||
319 | unless $value; | ||||||
320 | 3 | 3 | $value = [$value] | ||||
321 | unless ref $value; | ||||||
322 | 3 | 3 | $types->{$type}{aliases} = $value; | ||||
323 | 3 | 3 | return $invocant; | ||||
324 | } | ||||||
325 | 6 | 5 | if ( exists $types->{$type} ) { | ||||
326 | 5 4 | 5 12 | return @{ $types->{$type}{aliases} } if wantarray; | ||||
327 | 1 | 2 | return $types->{$type}{aliases}; | ||||
328 | } | ||||||
329 | } | ||||||
330 | 4 | 9 | return wantarray ? () : undef; | ||||
331 | } | ||||||
332 | |||||||
333 | # _types_by_alias | ||||||
334 | # In list context, returns a hash of aliases and their correspondin | ||||||
335 | # message type codes. | ||||||
336 | sub _types_by_alias | ||||||
337 | { | ||||||
338 | 21 | 15 | my ( $invocant ) = @_; | ||||
339 | 21 | 17 | my $types = $invocant->_types; | ||||
340 | 21 | 19 | my %long_types; | ||||
341 | 21 | 39 | for my $type ( keys %$types ) { | ||||
342 | 777 | 1463 | %long_types | ||||
343 | 189 189 | 276 151 | = ( %long_types, map { $_ => $type } @{ $types->{$type}{aliases} } ); | ||||
344 | 189 | 594 | $long_types{ $types->{$type}{tlc} } = $type | ||||
345 | if $types->{$type}{tlc}; | ||||||
346 | } | ||||||
347 | 21 | 167 | return wantarray ? %long_types : \%long_types; | ||||
348 | } | ||||||
349 | |||||||
350 | # _update_type_on_id_change | ||||||
351 | # Check or change whether or not message types are set automatically | ||||||
352 | # when message ids are set. The cascade is enabled by default. | ||||||
353 | 2 | 5 | my $auto_type = 1; | ||||
354 | |||||||
355 | sub _update_type_on_id_change | ||||||
356 | { | ||||||
357 | 30 | 18 | my ( $invocant, $value ) = @_; | ||||
358 | 30 | 55 | return $auto_type | ||||
359 | unless @_ > 1; | ||||||
360 | 1 | 1 | $auto_type = !!$value; | ||||
361 | 1 | 1 | return $invocant; | ||||
362 | } | ||||||
363 | |||||||
364 | 2 | 2 | my $auto_level = 1; | ||||
365 | |||||||
366 | # _update_level_on_type_change | ||||||
367 | # Check or change whether or not message levels are set automatically | ||||||
368 | # when message types are set. The cascade is enabled by default. | ||||||
369 | sub _update_level_on_type_change | ||||||
370 | { | ||||||
371 | 31 | 19 | my ( $invocant, $value ) = @_; | ||||
372 | 31 | 53 | return $auto_level | ||||
373 | unless @_ > 1; | ||||||
374 | 1 | 2 | $auto_level = !!$value; | ||||
375 | 1 | 1 | return $invocant; | ||||
376 | } | ||||||
377 | |||||||
378 | # _minimum_verbosity | ||||||
379 | # Returns the minimum verbosity level, always the same level as | ||||||
380 | # error messages. | ||||||
381 | 2 | 15 | my $min_verbosity = __PACKAGE__->_type_level( 'E' ); | ||||
382 | |||||||
383 | 1 | 2 | sub _minimum_verbosity {$min_verbosity} | ||||
384 | |||||||
385 | # _verbosity | ||||||
386 | # Returns the current verbosity level, which is greater than or | ||||||
387 | # equal to the severity level of all messages to be issued. | ||||||
388 | 2 | 2 | my $cur_verbosity = __PACKAGE__->_type_level( 'D' ); | ||||
389 | |||||||
390 | sub verbosity | ||||||
391 | { | ||||||
392 | 28 | 1 | 18 | my ( $invocant, $value ) = @_; | |||
393 | 28 | 55 | return $cur_verbosity | ||||
394 | unless @_ > 1; | ||||||
395 | 5 | 10 | if ( $value =~ /^\d+$/ ) { | ||||
396 | 2 | 1 | $cur_verbosity = 0 + $value; | ||||
397 | } | ||||||
398 | else { | ||||||
399 | 3 | 4 | my $types = $invocant->_types; | ||||
400 | 3 | 3 | $value = uc( $value ); | ||||
401 | 3 | 5 | if ( length( $value ) > 1 ) { | ||||
402 | 2 | 2 | my $long_types = $invocant->_types_by_alias; | ||||
403 | 2 | 17 | $value = $long_types->{$value} || 'D'; | ||||
404 | } | ||||||
405 | 3 | 5 | $value = $types->{$value}{level} | ||||
406 | if index( $invocant->_message_types, $value ) > -1; | ||||||
407 | 3 | 5 | $cur_verbosity = 0 + ( $value || 0 ); | ||||
408 | } | ||||||
409 | 5 | 5 | $cur_verbosity = $min_verbosity | ||||
410 | if $cur_verbosity < $min_verbosity; | ||||||
411 | 5 | 5 | return $invocant; | ||||
412 | } | ||||||
413 | |||||||
414 | # _default_timestamp_format | ||||||
415 | # Check or change the default timestamp format. | ||||||
416 | 2 | 2 | my $timestamp_format = '%a %x %T'; | ||||
417 | |||||||
418 | sub _default_timestamp_format | ||||||
419 | { | ||||||
420 | 6 | 5 | my ( $invocant, $value ) = @_; | ||||
421 | 6 | 15 | return $timestamp_format | ||||
422 | unless @_ > 1; | ||||||
423 | 2 | 5 | $timestamp_format = $value || ''; | ||||
424 | 2 | 3 | return $invocant; | ||||
425 | } | ||||||
426 | |||||||
427 | # _alert | ||||||
428 | # The handler used by the message issuer ("issue") to deliver | ||||||
429 | # an "alert" message. | ||||||
430 | sub _alert | ||||||
431 | { | ||||||
432 | 1 | 1 | my ( $message ) = @_; | ||||
433 | 1 | 2 | @_ = $message->{output}; | ||||
434 | 1 | 2 | require Carp; | ||||
435 | 1 | 74 | goto &Carp::confess; | ||||
436 | } | ||||||
437 | |||||||
438 | # _crit | ||||||
439 | # The handler used by the message issuer ("issue") to deliver | ||||||
440 | # a "critical" message. | ||||||
441 | sub _crit | ||||||
442 | { | ||||||
443 | 2 | 3 | my ( $message ) = @_; | ||||
444 | 2 | 3 | @_ = $message->{output}; | ||||
445 | 2 | 5 | require Carp; | ||||
446 | 2 | 198 | goto &Carp::confess; | ||||
447 | } | ||||||
448 | |||||||
449 | # _err | ||||||
450 | # The handler used by the message issuer ("issue") to deliver | ||||||
451 | # an "error" message. | ||||||
452 | sub _err | ||||||
453 | { | ||||||
454 | 1 | 1 | my ( $message ) = @_; | ||||
455 | 1 | 2 | @_ = $message->{output}; | ||||
456 | 1 | 2 | require Carp; | ||||
457 | 1 | 108 | goto &Carp::carp; | ||||
458 | } | ||||||
459 | |||||||
460 | # _warning | ||||||
461 | # The handler used by the message issuer ("issue") to deliver | ||||||
462 | # a "warning" message. | ||||||
463 | sub _warning | ||||||
464 | { | ||||||
465 | 1 | 2 | my ( $message ) = @_; | ||||
466 | 1 | 2 | @_ = $message->{output}; | ||||
467 | 1 | 6 | require Carp; | ||||
468 | 1 | 116 | goto &Carp::carp; | ||||
469 | } | ||||||
470 | |||||||
471 | # _notice | ||||||
472 | # The handler used by the message issuer ("issue") to deliver | ||||||
473 | # a "notice" message. | ||||||
474 | sub _notice | ||||||
475 | { | ||||||
476 | 2 | 4 | my ( $message ) = @_; | ||||
477 | 2 | 46 | print STDERR "$message->{output}\n"; | ||||
478 | 2 | 8 | return $message; | ||||
479 | } | ||||||
480 | |||||||
481 | # _info | ||||||
482 | # The handler used by the message issuer ("issue") to deliver | ||||||
483 | # an "info" message. | ||||||
484 | sub _info | ||||||
485 | { | ||||||
486 | 4 | 3 | my ( $message ) = @_; | ||||
487 | 4 | 80 | print STDOUT "$message->{output}\n"; | ||||
488 | 4 | 11 | return $message; | ||||
489 | } | ||||||
490 | |||||||
491 | # _diagnostic | ||||||
492 | # The handler used by the message issuer ("issue") to deliver | ||||||
493 | # a "diagnostic" message. | ||||||
494 | # | ||||||
495 | # Diagnostic messages are, by default, issueted using a TAP-friendly | ||||||
496 | # prefix ('# '), making them helpful in test modules. | ||||||
497 | sub _diagnostic | ||||||
498 | { | ||||||
499 | 1 | 1 | my ( $message ) = @_; | ||||
500 | 1 | 18 | print STDOUT "# $message->{output}\n"; | ||||
501 | 1 | 3 | return $message; | ||||
502 | } | ||||||
503 | |||||||
504 | # _prompt | ||||||
505 | # The handler used by the message issuer ("issue") to deliver | ||||||
506 | # a "response" message. | ||||||
507 | # | ||||||
508 | # Response messages are displayed and will block until a response | ||||||
509 | # is received from stdin. The response is accessible via the | ||||||
510 | # message's response method and, initially, also via Perl's "$_" | ||||||
511 | # variable. | ||||||
512 | 2 | 3 | *Message::String::INPUT = \*STDIN; | ||||
513 | |||||||
514 | sub _prompt | ||||||
515 | { | ||||||
516 | 1 | 2 | my ( $message ) = @_; | ||||
517 | 1 | 15 | print STDOUT "$message->{output}"; | ||||
518 | 1 | 3 | ReadMode( $message->readmode, \*Message::String::INPUT ); | ||||
519 | 1 | 34 | chomp( $message->{response} = <INPUT> ); | ||||
520 | 1 | 2 | ReadMode( 'normal', \*Message::String::INPUT ); | ||||
521 | 1 | 10 | $_ = $message->{response}; | ||||
522 | 1 | 2 | return $message; | ||||
523 | } | ||||||
524 | |||||||
525 | # _other | ||||||
526 | # The handler used by the message issuer ("issue") to deliver | ||||||
527 | # any other type of message. | ||||||
528 | sub _other | ||||||
529 | { | ||||||
530 | 4 | 4 | my ( $message ) = @_; | ||||
531 | 4 | 68 | print STDOUT "$message->{output}\n"; | ||||
532 | 4 | 9 | return $message; | ||||
533 | } | ||||||
534 | |||||||
535 | # _should_be_issued | ||||||
536 | # Returns 1 if the issuer should go ahead and issue to an | ||||||
537 | # issueter to deliver the message. | ||||||
538 | # Returns 0 if the issuer should just quietly return the | ||||||
539 | # message object. | ||||||
540 | # | ||||||
541 | # Messages are normally issueted (a) in void context (i.e. it is | ||||||
542 | # clear from their usage that the message should "do" something), and | ||||||
543 | # (b) if the message severity level is less than or equal to the | ||||||
544 | # current verbosity level. | ||||||
545 | sub _should_be_issued | ||||||
546 | { | ||||||
547 | 51 | 36 | my ( $message, $wantarray ) = @_; | ||||
548 | 51 | 129 | return 0 if defined $wantarray; | ||||
549 | 17 | 29 | return 0 if $message->verbosity < $message->_type_level( $message->type ); | ||||
550 | 17 | 27 | return 1; | ||||
551 | } | ||||||
552 | |||||||
553 | # _issue | ||||||
554 | # The message issuer. Oversees formatting, decision as to whether | ||||||
555 | # to issue, or return message object, and how to issue. | ||||||
556 | sub _issue | ||||||
557 | { | ||||||
558 | 51 | 50 | my ( $message ) = &_format; # Simply call "_format" using same "@_" | ||||
559 | 51 | 56 | return $message unless $message->_should_be_issued( wantarray ); | ||||
560 | 17 | 21 | my $types = $message->_types; | ||||
561 | 17 | 15 | my $type = $message->type; | ||||
562 | 17 | 31 | my $issue_using = $types->{$type}{issue} | ||||
563 | if exists $types->{$type}; | ||||||
564 | 17 | 25 | $issue_using = \&_other unless $issue_using; | ||||
565 | 17 | 20 | @_ = $message; | ||||
566 | 17 | 28 | goto &$issue_using; | ||||
567 | } | ||||||
568 | |||||||
569 | # _format | ||||||
570 | # Format the message's "output" attribute ready for issue. | ||||||
571 | sub _format | ||||||
572 | { | ||||||
573 | 51 | 42 | my ( $message, @args ) = @_; | ||||
574 | 51 | 36 | my $txt = ''; | ||||
575 | 51 | 66 | $txt .= $message->_message_timestamp_text | ||||
576 | if $message->_type_timestamp( $message->type ); | ||||||
577 | 51 | 438 | $txt .= $message->_message_tlc_text | ||||
578 | if $message->_type_tlc( $message->type ); | ||||||
579 | 51 | 62 | $txt .= $message->_message_id_text | ||||
580 | if $message->_type_id( $message->type ); | ||||||
581 | 51 | 64 | if ( @args ) { | ||||
582 | 6 | 12 | $txt .= sprintf( $message->{template}, @args ); | ||||
583 | } | ||||||
584 | else { | ||||||
585 | 45 | 46 | $txt .= $message->{template}; | ||||
586 | } | ||||||
587 | 51 | 60 | $message->output( $txt ); | ||||
588 | 51 | 46 | return $message; | ||||
589 | } | ||||||
590 | |||||||
591 | # _message_timestamp_text | ||||||
592 | # Returns the text used to represent time in the message's output. | ||||||
593 | sub _message_timestamp_text | ||||||
594 | { | ||||||
595 | 2 | 2 | my ( $message ) = @_; | ||||
596 | 2 | 2 | my $timestamp_format = $message->_type_timestamp( $message->type ); | ||||
597 | 2 | 8 | my $time = DateTime->now; | ||||
598 | 2 | 371 | return $time->strftime( $message->_default_timestamp_format ) . ' ' | ||||
599 | if $timestamp_format eq '1'; | ||||||
600 | 1 | 2 | return $time->strftime( $timestamp_format ) . ' '; | ||||
601 | } | ||||||
602 | |||||||
603 | # _message_tlc_text | ||||||
604 | # Returns the text used to represent three-letter type code in the | ||||||
605 | # message's output. | ||||||
606 | sub _message_tlc_text | ||||||
607 | { | ||||||
608 | 4 | 3 | my ( $message ) = @_; | ||||
609 | 4 | 5 | my $tlc = $message->_type_tlc( $message->type ); | ||||
610 | 4 | 9 | return sprintf( '*%s* ', uc( $tlc ) ); | ||||
611 | } | ||||||
612 | |||||||
613 | # _prepend_message_id | ||||||
614 | # Returns the text used to represent the identity of the message | ||||||
615 | # being output. | ||||||
616 | sub _message_id_text | ||||||
617 | { | ||||||
618 | 7 | 5 | my ( $message ) = @_; | ||||
619 | 7 | 11 | return sprintf( '%s ', uc( $message->id ) ); | ||||
620 | } | ||||||
621 | |||||||
622 | # id | ||||||
623 | # Set or get the message's identity. The identity must be a valid Perl | ||||||
624 | # subroutine identifier. | ||||||
625 | |||||||
626 | 2 | 106 | my %bad_identifiers = map +( $_, 1 ), qw/ | ||||
627 | BEGIN INIT CHECK END DESTROY | ||||||
628 | AUTOLOAD STDIN STDOUT STDERR ARGV | ||||||
629 | ARGVOUT ENV INC SIG UNITCHECK | ||||||
630 | __LINE__ __FILE__ __PACKAGE__ __DATA__ __SUB__ | ||||||
631 | __END__ __ANON__ | ||||||
632 | /; | ||||||
633 | |||||||
634 | sub id | ||||||
635 | { | ||||||
636 | 64 | 1 | 39 | my ( $message, $value ) = @_; | |||
637 | 64 | 92 | return $message->{id} | ||||
638 | unless @_ > 1; | ||||||
639 | 28 | 22 | my $short_types = $message->_message_types; | ||||
640 | 28 | 15 | my $type; | ||||
641 | 28 | 84 | if ( $value =~ m{(^.+):([${short_types}])$} ) { | ||||
642 | 1 | 3 | ( $value, $type ) = ( $1, $2 ); | ||||
643 | } | ||||||
644 | 28 | 122 | C_BAD_MESSAGE_ID( $value ) | ||||
645 | 2 2 2 | 6496 1 18 | unless $value && $value =~ /^[\p{Alpha}_\-][\p{Digit}\p{Alpha}_\-]*$/; | ||||
646 | 28 | 30 | C_BAD_MESSAGE_ID( $value ) | ||||
647 | if exists $bad_identifiers{$value}; | ||||||
648 | 28 | 22 | if ( $message->_update_type_on_id_change ) { | ||||
649 | 28 | 16 | if ( $type ) { | ||||
650 | 1 | 1 | $message->type( $type ); | ||||
651 | } | ||||||
652 | else { | ||||||
653 | 27 | 135 | if ( $value =~ /[_\d]([${short_types}])$/ ) { | ||||
654 | 1 | 1 | $message->type( $1 ); | ||||
655 | } | ||||||
656 | elsif ( $value =~ /^([${short_types}])[_\d]/ ) { | ||||||
657 | 9 | 7 | $message->type( $1 ); | ||||
658 | } | ||||||
659 | else { | ||||||
660 | 17 | 13 | my %long_types = $message->_types_by_alias; | ||||
661 | 2270 | 983 | my $long_types = join '|', | ||||
662 | 17 | 75 | sort { length( $b ) <=> length( $a ) } keys %long_types; | ||||
663 | 17 | 1353 | if ( $value =~ /(${long_types})$/ ) { | ||||
664 | 1 | 2 | $message->type( $long_types{$1} ); | ||||
665 | } | ||||||
666 | elsif ( $value =~ /^(${long_types})/ ) { | ||||||
667 | 15 | 31 | $message->type( $long_types{$1} ); | ||||
668 | } | ||||||
669 | else { | ||||||
670 | 1 | 1 | $message->type( 'M' ); | ||||
671 | } | ||||||
672 | } | ||||||
673 | } | ||||||
674 | } | ||||||
675 | 28 | 22 | $message->{id} = $value; | ||||
676 | 28 | 22 | return $message; | ||||
677 | } ## end sub id | ||||||
678 | } ## end BEGIN | ||||||
679 | |||||||
680 | # _export_messages | ||||||
681 | # Oversees the injection of message issuers into the target namespace. | ||||||
682 | # | ||||||
683 | # If messages are organised into one or more tag groups, then this method | ||||||
684 | # also ensuring that the target namespace is an Exporter before updating | ||||||
685 | # the @EXPORT_OK, %EXPORT_TAGS in that namespace with details of the | ||||||
686 | # messages being injected. To be clear, messages must be grouped before | ||||||
687 | # this method stomps over the target namespace's @ISA, @EXPORT_OK, and | ||||||
688 | # %EXPORT_TAGS. | ||||||
689 | # | ||||||
690 | # The "main" namespace is an exception in that it never undergoes any | ||||||
691 | # Exporter-related updates. | ||||||
692 | sub _export_messages | ||||||
693 | { | ||||||
694 | 2 2 2 | 6 0 260 | no strict 'refs'; | ||||
695 | 22 | 18 | my ( $package, $params ) = @_; | ||||
696 | 22 | 27 | my ( $ns, $messages, $export_tags, $export_ok, $export ) | ||||
697 | 22 | 8 | = @{$params}{qw/namespace messages export_tags export_ok export/}; | ||||
698 | 22 | 18 | for my $message ( @$messages ) { | ||||
699 | 28 | 24 | $message->_inject_into_namespace( $ns ); | ||||
700 | } | ||||||
701 | 22 | 71 | $package->_refresh_namespace_export_tags( $ns, $export_tags, $messages ) | ||||
702 | if ref( $export_tags ) && @$export_tags; | ||||||
703 | 22 | 23 | $package->_refresh_namespace_export_ok( $ns, $messages ) | ||||
704 | if $export_ok; | ||||||
705 | 22 | 21 | $package->_refresh_namespace_export( $ns, $messages ) | ||||
706 | if $export; | ||||||
707 | 22 | 16 | return $package; | ||||
708 | } | ||||||
709 | |||||||
710 | # _inject_into_namespace_a_message | ||||||
711 | # Clone the issuer and inject an appropriately named clone into | ||||||
712 | # the tartget namespace. Cloning helps avoid the pitfalls associated | ||||||
713 | # with renaming duplicate anonymous code references. | ||||||
714 | sub _inject_into_namespace | ||||||
715 | { | ||||||
716 | 2 2 2 | 4 1 286 | no strict 'refs'; | ||||
717 | 28 | 14 | my ( $message, $ns ) = @_; | ||||
718 | 28 28 | 14 27 | my ( $id, $type ) = @{$message}{ 'id', 'type' }; | ||||
719 | 28 | 23 | my $sym = "$ns\::$id"; | ||||
720 | 28 | 20 | $sym =~ s/-/_/g; | ||||
721 | # Clone the issuer, otherwise naming the __ANON__ function could | ||||||
722 | # be a little dicey! | ||||||
723 | my $clone = sub { | ||||||
724 | # Must "close over" message to clone. | ||||||
725 | 51 | 0 0 0 | 82 | @_ = ( $message, @_ ); # Make sure we pass the message on | |||
726 | 51 | 84 | goto &_issue; # ... and keep the calling frame in-tact! | ||||
727 | 28 | 71 | }; | ||||
728 | # Name and inject the message issuer | ||||||
729 | 28 | 142 | *$sym = set_subname( $sym => $clone ); | ||||
730 | # Record the message provider and rebless the message | ||||||
731 | 28 | 25 | $message->_provider( $ns )->_rebless( "$ns\::Message::String" ); | ||||
732 | 28 | 32 | return $message; | ||||
733 | } | ||||||
734 | |||||||
735 | # _refresh_namespace_export | ||||||
736 | # Updates the target namespace's @EXPORT, adding the names of any | ||||||
737 | # message issuers. | ||||||
738 | sub _refresh_namespace_export | ||||||
739 | { | ||||||
740 | 2 2 2 | 5 1 201 | no strict 'refs'; | ||||
741 | 8 | 6 | my ( $package, $ns, $messages ) = @_; | ||||
742 | 8 | 8 | return $package | ||||
743 | unless $package->_ensure_namespace_is_exporter( $ns ); | ||||||
744 | 7 7 | 6 40 | my @symbols = map { $_->{id} } @$messages; | ||||
745 | 7 7 | 17 36 | @{"$ns\::EXPORT"} | ||||
746 | 7 | 12 | = distinct( @symbols, @{"$ns\::EXPORT"} ); | ||||
747 | 7 | 13 | return $package; | ||||
748 | } | ||||||
749 | |||||||
750 | # _refresh_namespace_export_ok | ||||||
751 | # Updates the target namespace's @EXPORT_OK, adding the names of any | ||||||
752 | # message issuers. | ||||||
753 | sub _refresh_namespace_export_ok | ||||||
754 | { | ||||||
755 | 2 2 2 | 4 2 190 | no strict 'refs'; | ||||
756 | 7 | 5 | my ( $package, $ns, $messages ) = @_; | ||||
757 | 7 | 5 | return $package | ||||
758 | unless $package->_ensure_namespace_is_exporter( $ns ); | ||||||
759 | 2 3 | 2 4 | my @symbols = map { $_->{id} } @$messages; | ||||
760 | 2 2 | 3 6 | @{"$ns\::EXPORT_OK"} | ||||
761 | 2 | 2 | = distinct( @symbols, @{"$ns\::EXPORT_OK"} ); | ||||
762 | 2 | 4 | return $package; | ||||
763 | } | ||||||
764 | |||||||
765 | # _refresh_namespace_export_tags | ||||||
766 | # Updates the target namespace's %EXPORT_TAGS, adding the names of any | ||||||
767 | # message issuers. | ||||||
768 | sub _refresh_namespace_export_tags | ||||||
769 | { | ||||||
770 | 2 2 2 | 4 0 314 | no strict 'refs'; | ||||
771 | 5 | 5 | my ( $package, $ns, $export_tags, $messages ) = @_; | ||||
772 | 5 | 4 | return $package | ||||
773 | unless $package->_ensure_namespace_is_exporter( $ns ); | ||||||
774 | 1 | 4 | return $package | ||||
775 | unless ref( $export_tags ) && @$export_tags; | ||||||
776 | 1 2 | 1 3 | my @symbols = map { $_->{id} } @$messages; | ||||
777 | 1 | 1 | for my $tag ( @$export_tags ) { | ||||
778 | 1 1 | 2 4 | ${"$ns\::EXPORT_TAGS"}{$tag} = [] | ||||
779 | 1 | 0 | unless defined ${"$ns\::EXPORT_TAGS"}{$tag}; | ||||
780 | 1 1 1 | 1 3 3 | @{ ${"$ns\::EXPORT_TAGS"}{$tag} } | ||||
781 | 1 1 | 1 0 | = distinct( @symbols, @{ ${"$ns\::EXPORT_TAGS"}{$tag} } ); | ||||
782 | } | ||||||
783 | 1 | 1 | return $package; | ||||
784 | } | ||||||
785 | |||||||
786 | # _ensure_namespace_is_exporter | ||||||
787 | # Returns 0 if the namespace is "main", and does nothing else. | ||||||
788 | # Returns 1 if the namespace is not "main", and prepends "Exporter" to the | ||||||
789 | # target namespace @ISA array. | ||||||
790 | sub _ensure_namespace_is_exporter | ||||||
791 | { | ||||||
792 | 2 2 2 | 4 2 243 | no strict 'refs'; | ||||
793 | 20 | 14 | my ( $invocant, $ns ) = @_; | ||||
794 | 20 | 26 | return 0 if $ns eq 'main'; | ||||
795 | 10 | 18 | require Exporter; | ||||
796 | 10 1 | 16 5 | unshift @{"$ns\::ISA"}, 'Exporter' | ||||
797 | unless $ns->isa( 'Exporter' ); | ||||||
798 | 10 | 14 | return 1; | ||||
799 | } | ||||||
800 | |||||||
801 | # _provider | ||||||
802 | # Sets or gets the package that provided the message. | ||||||
803 | sub _provider | ||||||
804 | { | ||||||
805 | 29 | 22 | my ( $message, $value ) = @_; | ||||
806 | 29 | 30 | return $message->{provider} | ||||
807 | unless @_ > 1; | ||||||
808 | 28 | 102 | $message->{provider} = $value; | ||||
809 | 28 | 34 | return $message; | ||||
810 | } | ||||||
811 | |||||||
812 | # _rebless | ||||||
813 | # Re-blesses a message using its id as the class name, and prepends the | ||||||
814 | # message's old class to the new namespace's @ISA array. | ||||||
815 | # | ||||||
816 | # Optionally, the developer may pass a sequence of method-name and code- | ||||||
817 | # reference pairs, which this method will set up in the message's new | ||||||
818 | # namespace. This crude facility allows for existing methods to be | ||||||
819 | # overriddden on a message by message basis. | ||||||
820 | # | ||||||
821 | # Though not actually required by any of the code in this module, this | ||||||
822 | # method has been made available to facilitate any special treatment | ||||||
823 | # a developer may want for a particular message. | ||||||
824 | sub _rebless | ||||||
825 | { | ||||||
826 | 2 2 2 | 4 1 1227 | no strict 'refs'; | ||||
827 | 29 | 28 | my ( $message, @pairs ) = @_; | ||||
828 | 29 | 24 | my $id = $message->id; | ||||
829 | 29 | 12 | my $class; | ||||
830 | 29 | 30 | if ( @pairs % 2 ) { | ||||
831 | 28 | 30 | $class = shift @pairs; | ||||
832 | } | ||||||
833 | else { | ||||||
834 | 1 | 3 | $class = join( '::', $message->_provider, $id ); | ||||
835 | } | ||||||
836 | 29 4 | 81 49 | push @{"$class\::ISA"}, ref( $message ) | ||||
837 | unless $class->isa( ref( $message ) ); | ||||||
838 | 29 | 35 | while ( @pairs ) { | ||||
839 | 1 | 1 | my $method = shift @pairs; | ||||
840 | 1 | 1 | my $coderef = shift @pairs; | ||||
841 | 1 | 6 | next unless $method && !ref( $method ); | ||||
842 | 1 | 10 | next unless ref( $coderef ) && ref( $coderef ) eq 'CODE'; | ||||
843 | 1 | 2 | my $sym = "$id\::$method"; | ||||
844 | 1 | 7 | *$sym = set_subname( $sym, $coderef ); | ||||
845 | } | ||||||
846 | 29 | 35 | return bless( $message, $class ); | ||||
847 | } | ||||||
848 | |||||||
849 | # readmode | ||||||
850 | # Set or get the message's readmode attribute. Typically, only Type R | ||||||
851 | # (Response) messages will set this attribute. | ||||||
852 | sub readmode | ||||||
853 | { | ||||||
854 | 2 | 1 | 2 | my ( $message, $value ) = @_; | |||
855 | 2 | 13 | return exists( $message->{readmode} ) ? $message->{readmode} : 0 | ||||
856 | unless @_ > 1; | ||||||
857 | 1 | 2 | $message->{readmode} = $value || 0; | ||||
858 | 1 | 0 | return $message; | ||||
859 | } | ||||||
860 | |||||||
861 | # response | ||||||
862 | # Set or get the message's response attribute. Typically, only Type R | ||||||
863 | # (Response) messages will set this attribute. | ||||||
864 | sub response | ||||||
865 | { | ||||||
866 | 3 | 1 | 3 | my ( $message, $value ) = @_; | |||
867 | 3 | 14 | return exists( $message->{response} ) ? $message->{response} : undef | ||||
868 | unless @_ > 1; | ||||||
869 | 1 | 2 | $message->{response} = $value; | ||||
870 | 1 | 2 | return $message; | ||||
871 | } | ||||||
872 | |||||||
873 | # output | ||||||
874 | # Set or get the message's output attribute. Typically, only the message | ||||||
875 | # formatter ("_format") would set this attribute. | ||||||
876 | sub output | ||||||
877 | { | ||||||
878 | 51 | 1 | 41 | my ( $message, $value ) = @_; | |||
879 | 51 | 49 | return exists( $message->{output} ) ? $message->{output} : undef | ||||
880 | unless @_ > 1; | ||||||
881 | 51 | 42 | $message->{output} = $value; | ||||
882 | 51 | 36 | return $message; | ||||
883 | } | ||||||
884 | |||||||
885 | # to_string | ||||||
886 | # Stringify the message. Return the "output" attribute if it exists and | ||||||
887 | # it has been defined, otherwise return the message's formatting template. | ||||||
888 | # The "" (stringify) operator for the message's class has been overloaded | ||||||
889 | # using this method. | ||||||
890 | sub to_string | ||||||
891 | { | ||||||
892 | 10 | 1 | 43 | return $_[0]{output}; | |||
893 | } | ||||||
894 | |||||||
895 | # template | ||||||
896 | # Set or get the message's formatting template. The template is any valid | ||||||
897 | # string that might otherwise pass for a "sprintf" format. | ||||||
898 | sub template | ||||||
899 | { | ||||||
900 | 31 | 1 | 19 | my ( $message, $value ) = @_; | |||
901 | 31 | 42 | return $message->{template} | ||||
902 | unless @_ > 1; | ||||||
903 | 28 | 21 | C_MISSING_TEMPLATE( $message->id ) | ||||
904 | unless $value; | ||||||
905 | 28 | 22 | $message->{template} = $value; | ||||
906 | 28 | 15 | return $message; | ||||
907 | } | ||||||
908 | |||||||
909 | # type | ||||||
910 | # The message's 1-character type code (A, N, I, C, E, W, M, R, D). | ||||||
911 | sub type | ||||||
912 | { | ||||||
913 | 264 | 1 | 168 | my ( $message, $value ) = @_; | |||
914 | 264 | 646 | return $message->{type} | ||||
915 | unless @_ > 1; | ||||||
916 | 29 | 20 | my $type = uc( $value ); | ||||
917 | 29 | 27 | if ( length( $type ) > 1 ) { | ||||
918 | 1 | 1 | my $long_types = $message->_types_by_alias; | ||||
919 | 1 | 8 | $type = $long_types->{$type} || 'M'; | ||||
920 | } | ||||||
921 | 29 | 23 | if ( $message->_update_level_on_type_change ) { | ||||
922 | 29 | 26 | my $level = $message->_type_level( $type ); | ||||
923 | 29 | 25 | $level = $message->_type_level( 'M' ) | ||||
924 | unless defined $level; | ||||||
925 | 29 | 23 | $message->level( $level ); | ||||
926 | } | ||||||
927 | 29 | 28 | delete $message->{types} | ||||
928 | if exists $message->{types}; | ||||||
929 | 29 | 21 | $message->{type} = $type; | ||||
930 | 29 | 127 | return $message; | ||||
931 | } | ||||||
932 | |||||||
933 | # level | ||||||
934 | # The message's severity level. | ||||||
935 | sub level | ||||||
936 | { | ||||||
937 | 51 | 1 | 28 | my ( $message, $value ) = @_; | |||
938 | 51 | 52 | return $message->{level} unless @_ > 1; | ||||
939 | 46 | 57 | if ( $value =~ /\D/ ) { | ||||
940 | 2 | 2 | my $type = uc( $value ); | ||||
941 | 2 | 4 | if ( length( $type ) > 1 ) { | ||||
942 | 1 | 2 | my $long_types = $message->_types_by_alias; | ||||
943 | 1 | 8 | $type = $long_types->{$type} || 'M'; | ||||
944 | } | ||||||
945 | 2 | 3 | $value = $message->_type_level( $type ); | ||||
946 | 2 | 3 | $value = $message->_type_level( 'M' ) | ||||
947 | unless defined $value; | ||||||
948 | } | ||||||
949 | 46 | 50 | $message->{level} = $value; | ||||
950 | 46 | 31 | return $message; | ||||
951 | } | ||||||
952 | |||||||
953 | 2 | 1724 | BEGIN { *severity = \&level } | ||||
954 | |||||||
955 | # _new_from_string | ||||||
956 | # Create one or more messages from a string. Messages are separated by | ||||||
957 | # newlines. Each message consists of a message identifier and a formatting | ||||||
958 | # template, which are themselves separated by one or more spaces or tabs. | ||||||
959 | sub _new_from_string | ||||||
960 | { | ||||||
961 | 1 | 1 | my ( $invocant, $string ) = @_; | ||||
962 | 1 | 1 | my @lines; | ||||
963 | 1 6 | 15 19 | for my $line ( grep { m{\S} && m{^[^#]} } | ||||
964 | split( m{\s*\n\s*}, $string ) ) | ||||||
965 | { | ||||||
966 | 4 | 8 | my ( $id, $text ) = split( m{[\s\t]+}, $line, 2 ); | ||||
967 | 4 | 20 | if ( @lines && $id =~ m{^[.]+$} ) { | ||||
968 | 1 | 5 | $lines[-1] =~ s{\z}{ $text}s; | ||||
969 | } | ||||||
970 | elsif ( @lines && $id =~ m{^[+]+$} ) { | ||||||
971 | 1 | 3 | $lines[-1] =~ s{\z}{\n$text}s; | ||||
972 | } | ||||||
973 | else { | ||||||
974 | 2 | 2 | push @lines, ( $id, $text ); | ||||
975 | } | ||||||
976 | } | ||||||
977 | 1 | 2 | return $invocant->_new_from_arrayref( \@lines ); | ||||
978 | } | ||||||
979 | |||||||
980 | # _new_from_arrayref | ||||||
981 | # Create one or more messages from an array. Each element of the array is | ||||||
982 | # an array of two elements: a message identifier and a formatting template. | ||||||
983 | sub _new_from_arrayref | ||||||
984 | { | ||||||
985 | 3 | 2 | my ( $invocant, $arrayref ) = @_; | ||||
986 | 3 | 6 | return $invocant->_new_from_hashref( {@$arrayref} ); | ||||
987 | } | ||||||
988 | |||||||
989 | # _new_from_hashref | ||||||
990 | # Create one or more messages from an array. Each element of the array is | ||||||
991 | # an array of two elements: a message identifier and a formatting template. | ||||||
992 | sub _new_from_hashref | ||||||
993 | { | ||||||
994 | 7 | 4 | my ( $invocant, $hashref ) = @_; | ||||
995 | 7 10 | 12 12 | return map { $invocant->_new( $_, $hashref->{$_} ) } keys %$hashref; | ||||
996 | } | ||||||
997 | |||||||
998 | # _new | ||||||
999 | # Create a new message from message identifier and formatting template | ||||||
1000 | # arguments. | ||||||
1001 | sub _new | ||||||
1002 | { | ||||||
1003 | 28 | 28 | my ( $class, $message_id, $message_template ) = @_; | ||||
1004 | 28 | 72 | $class = ref( $class ) || $class; | ||||
1005 | 28 | 28 | my $message = bless( {}, $class ); | ||||
1006 | 28 | 25 | $message->id( $message_id ); | ||||
1007 | s{\\n}{\n}g, | ||||||
1008 | s{\\r}{\r}g, | ||||||
1009 | s{\\t}{\t}g, | ||||||
1010 | s{\\a}{\a}g, | ||||||
1011 | 28 | 57 | s{\\s}{ }g for $message_template; | ||||
1012 | 28 | 29 | $message->template( $message_template ); | ||||
1013 | |||||||
1014 | 28 | 20 | if ( $message->type eq 'R' && $message->template =~ m{password}si ) { | ||||
1015 | 1 | 1 | $message->readmode( 'noecho' ); | ||||
1016 | } | ||||||
1017 | 28 | 56 | return $message; | ||||
1018 | } | ||||||
1019 | # import | ||||||
1020 | # Import new messages into the caller's namespace. | ||||||
1021 | sub import | ||||||
1022 | { | ||||||
1023 | 19 | 32 | my ( $package, my @args ) = @_; | ||||
1024 | 19 | 23 | if ( @args ) { | ||||
1025 | 17 | 7 | my ( @tags, @messages, $export, $export_ok ); | ||||
1026 | 17 | 18 | my $caller = caller; | ||||
1027 | 17 | 15 | while ( @args ) { | ||||
1028 | 49 | 32 | my $this_arg = shift( @args ); | ||||
1029 | 49 | 60 | my $ref_type = reftype( $this_arg ); | ||||
1030 | 49 | 33 | if ( $ref_type ) { | ||||
1031 | 7 | 8 | if ( $ref_type eq 'HASH' ) { | ||||
1032 | 4 | 5 | push @messages, __PACKAGE__->_new_from_hashref( $this_arg ); | ||||
1033 | } | ||||||
1034 | elsif ( $ref_type eq 'ARRAY' ) { | ||||||
1035 | 2 | 2 | push @messages, __PACKAGE__->_new_from_arrayref( $this_arg ); | ||||
1036 | } | ||||||
1037 | else { | ||||||
1038 | 1 | 2 | C_EXPECT_HAREF_OR_KVPL; | ||||
1039 | } | ||||||
1040 | 6 | 20 | $package->_export_messages( | ||||
1041 | { namespace => $caller, | ||||||
1042 | messages => \@messages, | ||||||
1043 | export_tags => \@tags, | ||||||
1044 | export_ok => $export_ok, | ||||||
1045 | export => $export, | ||||||
1046 | } | ||||||
1047 | ) if @messages; | ||||||
1048 | 6 | 8 | @tags = (); | ||||
1049 | 6 | 5 | @messages = (); | ||||
1050 | 6 | 3 | undef $export; | ||||
1051 | 6 | 6 | undef $export_ok; | ||||
1052 | } | ||||||
1053 | else { | ||||||
1054 | 42 | 65 | if ( $this_arg eq 'EXPORT' ) { | ||||
1055 | 10 | 10 | if ( @messages ) { | ||||
1056 | 2 | 5 | $package->_export_messages( | ||||
1057 | { namespace => $caller, | ||||||
1058 | messages => \@messages, | ||||||
1059 | export_tags => \@tags, | ||||||
1060 | export_ok => $export_ok, | ||||||
1061 | export => $export, | ||||||
1062 | } | ||||||
1063 | ); | ||||||
1064 | 2 | 4 | @messages = (); | ||||
1065 | 2 | 1 | @tags = (); | ||||
1066 | } | ||||||
1067 | 10 | 7 | $export = 1; | ||||
1068 | 10 | 10 | undef $export_ok; | ||||
1069 | } | ||||||
1070 | elsif ( $this_arg eq 'EXPORT_OK' ) { | ||||||
1071 | 3 | 3 | if ( @messages ) { | ||||
1072 | 1 | 2 | $package->_export_messages( | ||||
1073 | { namespace => $caller, | ||||||
1074 | messages => \@messages, | ||||||
1075 | export_tags => \@tags, | ||||||
1076 | export_ok => $export_ok, | ||||||
1077 | export => $export, | ||||||
1078 | } | ||||||
1079 | ); | ||||||
1080 | 1 | 2 | @messages = (); | ||||
1081 | 1 | 0 | @tags = (); | ||||
1082 | } | ||||||
1083 | 3 | 3 | $export_ok = 1; | ||||
1084 | 3 | 3 | undef $export; | ||||
1085 | } | ||||||
1086 | elsif ( substr( $this_arg, 0, 1 ) eq ':' ) { | ||||||
1087 | 9 | 22 | ( my $tag = substr( $this_arg, 1 ) ) =~ s/(?:^\s+|\s+$)//; | ||||
1088 | 9 | 16 | my @new_tags = split m{\s*[,]?\s*[:]}, $tag; | ||||
1089 | 9 | 10 | push @tags, @new_tags; | ||||
1090 | 9 | 16 | $package->_export_messages( | ||||
1091 | { namespace => $caller, | ||||||
1092 | messages => \@messages, | ||||||
1093 | export_tags => \@tags, | ||||||
1094 | export_ok => $export_ok, | ||||||
1095 | export => $export, | ||||||
1096 | } | ||||||
1097 | ) if @messages; | ||||||
1098 | 9 | 8 | @messages = (); | ||||
1099 | 9 | 6 | $export_ok = 1; | ||||
1100 | 9 | 10 | undef $export; | ||||
1101 | } | ||||||
1102 | elsif ( $this_arg eq 'void' ) { | ||||||
1103 | 1 | 5 | Syntax::Feature::Void->import( 'void' ); | ||||
1104 | } | ||||||
1105 | else { | ||||||
1106 | 19 | 13 | if ( @args ) { | ||||
1107 | 18 | 19 | push @messages, __PACKAGE__->_new( $this_arg, shift( @args ) ); | ||||
1108 | } | ||||||
1109 | else { | ||||||
1110 | 1 | 2 | push @messages, __PACKAGE__->_new_from_string( $this_arg ); | ||||
1111 | } | ||||||
1112 | } | ||||||
1113 | } ## end else [ if ( $ref_type ) ] | ||||||
1114 | } ## end while ( @args ) | ||||||
1115 | 16 | 23 | if ( @messages ) { | ||||
1116 | 12 | 29 | $package->_export_messages( | ||||
1117 | { namespace => $caller, | ||||||
1118 | messages => \@messages, | ||||||
1119 | export_tags => \@tags, | ||||||
1120 | export_ok => $export_ok, | ||||||
1121 | export => $export, | ||||||
1122 | } | ||||||
1123 | ); | ||||||
1124 | } | ||||||
1125 | } ## end if ( @args ) | ||||||
1126 | 18 | 449 | return $package; | ||||
1127 | } ## end sub import | ||||||
1128 | |||||||
1129 | use message { | ||||||
1130 | 2 | 5 | C_EXPECT_HAREF_OR_KVPL => | ||||
1131 | 'Expected list of name-value pairs, or reference to an ARRAY or HASH of the same', | ||||||
1132 | C_BAD_MESSAGE_ID => 'Message identifier "%s" is invalid', | ||||||
1133 | C_MISSING_TEMPLATE => 'Message with identifier "%s" has no template' | ||||||
1134 | 2 2 | 2 8 | }; | ||||
1135 | |||||||
1136 | 1; | ||||||
1137 | |||||||
1138 - 2067 | =pod =encoding utf8 =head1 NAME Message::String - A pragma to declare and organise messaging. =head1 SYNOPSIS This module helps you organise, identify, define and use messaging specific to an application or message domain. =head2 Using the pragma to define message strings =over =item The pragma's package name may be used directly: # Declare a single message use Message::String INF_GREETING => "Hello, World!"; # Declare multiple messages use Message::String { INF_GREETING => "I am completely operational, " . "and all my circuits are functioning perfectly.", RSP_DO_WHAT => "What would you have me do?\n", NTC_FAULT => "I've just picked up a fault in the %s unit.", CRT_NO_CAN_DO => "I'm sorry, %s. I'm afraid I can't do that", }; =item Or, after loading the module, the C<message> alias may be used: # Load the module use Message::String; # Declare a single message use message INF_GREETING => "Hello, World!"; # Declare multiple messages use message { INF_GREETING => "I am completely operational, " . "and all my circuits are functioning perfectly.", RSP_DO_WHAT => "What would you have me do?\n", NTC_FAULT => "I've just picked up a fault in the %s unit.", CRT_NO_CAN_DO => "I'm sorry, %s. I'm afraid I can't do that", }; (B<Note>: the C<message> pragma may be favoured in future examples.) =back =head2 Using message strings in your application Using message strings in your code is really easy, and you have choice about how to do so: =over =item B<Example 1> # Ah, the joyless tedium that is composing strings using constants... $name = "Dave"; print INF_GREETING, "\n"; print RSP_DO_WHAT; chomp(my $response = <STDIN>); if ($response =~ /Open the pod bay doors/i) { die sprintf(CRT_NO_CAN_DO, $name); } printf NTC_FAULT . "\n", 'AE-35'; Using messages this way can sometimes be useful but, on this occasion, aptly demonstrates why constants get a bad rap. This pattern of usage works fine, though you could just have easily used the C<constant> pragma, or one of the alternatives. =item B<Example 2> $name = 'Dave'; INF_GREETING; # Display greeting (stdout) RSP_DO_WHAT; # Prompt for response (stdout/stdin) if ( /Open the pod bay doors/ ) # Check response; trying $_ but { # RSP_DO_WHAT->response works, too! CRT_NO_CAN_DO($name); # Throw hissy fit (Carp::croak) } NTC_FAULT('AE-35'); # Issue innocuous notice (stderr) =back C<Message::String> objects take care of things like printing info messages to stdout; printing response messages to stdout, and gathering input from STDIN; putting notices on stderr, and throwing exceptions for critical errors. They do all the ancillary work so you don't have to; hiding away oft used sprinklings that make code noisy. =head2 Exporting message strings to other packages It is also possible to have a module export its messages for use by other packages. By including C<EXPORT> or C<EXPORT_OK> in the argument list, before your messages are listed, you can be sure that your package will export your symbols one way or the other. The examples below show how to exports using C<EXPORT> and C<EXPORT_OK>; they also demonstrate how to define messages using less onerous string catalogues and, when doing so, how to split longer messages in order to keep the lengths of your lines manageable: =over =item B<Example 1> package My::App::Messages; use Message::String EXPORT => << 'EOF'; INF_GREETING I am completely operational, ... and all my circuits are functioning perfectly. RSP_DO_WHAT What would you have me do?\n NTC_FAULT I've just picked up a fault in the %s unit. CRT_NO_CAN_DO I'm sorry, %s. I'm afraid I can't do that EOF 1; # Meanwhile, back at main:: use My::App::Messages; # No choice. We get everything! =item B<Example 2> package My::App::Messages; use Message::String EXPORT_OK => << 'EOF'; INF_GREETING I am completely operational, ... and all my circuits are functioning perfectly. RSP_DO_WHAT What would you have me do?\n NTC_FAULT I've just picked up a fault in the %s unit. CRT_NO_CAN_DO I'm sorry, %s. I'm afraid I can't do that EOF 1; # Meanwhile, back at main:: use My::App::Messages 'INF_GREETING'; # Import what we need (B<Note>: you were probably astute enough to notice that, despite the HEREDOC marker being enclosed in single quotes, there is a C<\n> at the end of one of the message definitions. This isn't an error; the message formatter will deal with that.) It is also possible to place messages in one or more groups by including the group tags in the argument list, before the messages are defined. Group tags I<must> start with a colon (C<:>). =item B<Example 3> package My::App::Messages; use My::App::Messages; use message ':MESSAGES' => { INF_GREETING => "I am completely operational, " . "and all my circuits are functioning perfectly.", RSP_DO_WHAT => "What would you have me do?\n", NTC_FAULT => "I've just picked up a fault in the %s unit.", }; use message ':MESSAGES', ':ERRORS' => { CRT_NO_CAN_DO => "I'm sorry, %s. I'm afraid I can't do that", }; 1; # Meanwhile, back at main:: use My::App::Messages ':ERRORS'; # Import the errors use My::App::Messages ':MESSAGE'; # Import everything =back Tagging messages causes your module's C<%EXPORT_TAGS> hash to be updated, with tagged messages also being added to your module's C<@EXPORT_OK> array. There is no expectation that you will make your package a descendant of the C<Exporter> class. Provided you aren't working in the C<main::> namespace then the calling package will be made a subclass of C<Exporter> automatically, as soon as it becomes clear that it is necessary. =head2 Recap of the highlights This brief introduction demonstrates, hopefully, that as well as being able to function like constants, message strings are way more sophisticated than constants. Perhaps your Little Grey Cells have also helped you make a few important deductions: =over =item * That the name not only identifies, but characterises a message. =item * That different types of message exist. =item * That handling is influenced by a message's type. =item * That messages are simple text, or they may be parameterised. =item * That calling context matters, particularly B<void> context. =back You possibly have more questions. Certainly, there is more to the story and these are just the highlights. The module is described in greater detail below. =head1 DESCRIPTION The C<Message::String> pragma and its alias (C<message>) are aimed at the programmer who wishes to organise, identify, define, use (or make available for use) message strings specific to an application or other message domain. C<Message::String> objects are not unlike constants, in fact, they may even be used like constants; they're just a smidge more helpful. Much of a script's lifetime is spent saying stuff, asking for stuff, maybe even complaining about stuff; but, most important of all, they have to do meaningful stuff, good stuff, the stuff they were designed to do. The trouble with saying, asking for, and complaining about stuff is the epic amount of repeated stuff that needs to be done just to do that kind of stuff. And that kind of stuff is like visual white noise when it's gets in the way of understanding and following a script's flow. We factor out repetetive code into reusable subroutines, web content into templates, but we do nothing about our script's messaging. Putting up with broken strings, quotes, spots and commas liberally peppered around the place as we compose and recompose strings doesn't seem to bother us. What if we could organise our application's messaging in a way that kept all of that noise out of the way? A way that allowed us to access messages using mnemonics but have useful, sensible and standard things happen when we do so. This module attempts to provide the tooling to do just that. =head1 METHODS C<Message::String> objects are created and injected into the symbol table during Perl's compilation phase so that they are accessible at runtime. Once the import method has done its job there is very little that may be done to meaningfully alter the identity, purpose or destiny of messages. A large majority of this module's methods, including constructors, are therefore notionally and conventionally protected. There are, however, a small number of public methods worth covering in this document. =head2 Public Methods =head3 import message->import(); message->import( @options, @message_group, ... ); message->import( @options, \%message_group, ... ); message->import( @options, \@message_group, ... ); message->import( @options, $message_group, ... ); The C<import> method is invoked at compile-time, whenever a C<use message> or C<use Message::String> directive is encountered. It processes any options and creates any requested messages, injecting message symbols into the caller's symbol table. B<Options> =over =item C<void> Makes the C<void> operator available for use in the calling module. Since the active aspects of message handling are only triggered in void context, it provides an extra level of comfort to developers who are unsure whether a statement will be executed in the correct context. The C<void> operator is B<essential> if testing with messages. The C<void> operator is provided by C<L<Syntax::Feature::Void>>. =item C<EXPORT> Ensures that the caller's C<@EXPORT> list includes the names of messages defined in the following group. # Have the caller mandate that these messages be imported: # use message EXPORT => { ... }; =item C<EXPORT_OK> Ensures that the caller's C<@EXPORT_OK> list includes the names of messages defined in the following group. The explicit use of C<EXPORT_OK> is not necessary when tag groups are being used and its use is implied. # Have the caller make these messages importable individually and # upon request: # use message EXPORT_OK => { ... }; =item C<:I<EXPORT-TAG>> One or more export tags may be listed, specifying that the following group of messages is to be added to the listed tag group(s). Any necessary updates to the caller's C<%EXPORT_TAGS> hash and C<@EXPORT_OK> array are made. The explicit use of C<EXPORT_OK> is unnecessary since its use is implied. Tags may listed as separately or together in the same compound strings, though must be prefixed with a colon (C<:>). # Grouping messages with a single tag: # use message ':FOO' => { ... }; # Four valid ways to group messages with multiple tags: # use message ':FOO',':BAR' => { ... }; use message ':FOO, :BAR' => { ... }; use message ':FOO :BAR' => { ... }; use message ':FOO:BAR' => { ... }; # Gilding-the-lily; not wrong, but not necessary: # use message ':FOO', EXPORT_OK => { ... }; =back Tag groups and other export options have no effect if the calling package is called C<main::>. If the calling package hasn't already been declared a subclass of C<Exporter> then the C<Exporter> package is loaded and the caller's C<@ISA> array will be updated to include it as the first element. (B<To do>: I should try to make this work with C<L<Sub::Exporter>>.) B<Defining Messages> A message is comprised of two tokens: =over =item The Message Identifier The message id should contain no whitespace characters, consist only of upper- and/or lowercase letters, digits, the underscore, and be valid as a Perl subroutine name. The id should I<ideally> be unique; at the very least, it B<must> be unique to the package in which it is defined. As well as naming a message, the message id is also used to determine the message type and severity. Try to organise your message catalogues using descriptive and consistent naming and type conventions. (Read the section about L<MESSAGE TYPES> to see how typing works.) =item The Message Template The template is the text part of the message. It could be a simple string, or it could be a C<sprintf> format complete with one or more parameter placeholders. A message may accept arguments, in which case C<sprintf> will merge the argument values with the template to produce the final output. =back Messages are defined in groups of one or more key-value pairs, and the C<import> method is quite flexible about how they are presented for processing. =over =item As a flat list of key-value pairs. use message INF_GREETING => "I am completely operational, " . "and all my circuits are functioning perfectly.", RSP_DO_WHAT => "What would you have me do?\n", NTC_FAULT => "I've just picked up a fault in the %s unit.", CRT_NO_CAN_DO => "I'm sorry, %s. I'm afraid I can't do that"; =item As an anonymous hash, or hash reference. use message { INF_GREETING => "I am completely operational, " . "and all my circuits are functioning perfectly.", RSP_DO_WHAT => "What would you have me do?\n", NTC_FAULT => "I've just picked up a fault in the %s unit.", CRT_NO_CAN_DO => "I'm sorry, %s. I'm afraid I can't do that", }; =item As an anonymous array, or array reference. use message [ INF_GREETING => "I am completely operational, " . "and all my circuits are functioning perfectly.", RSP_DO_WHAT => "What would you have me do?\n", NTC_FAULT => "I've just picked up a fault in the %s unit.", CRT_NO_CAN_DO => "I'm sorry, %s. I'm afraid I can't do that", ]; =item As a string (perhaps using a HEREDOC). use message << 'EOF'; INF_GREETING I am completely operational, ... and all my circuits are functioning perfectly. RSP_DO_WHAT What would you have me do?\n NTC_FAULT I've just picked up a fault in the %s unit. CRT_NO_CAN_DO I'm sorry, %s. I'm afraid I can't do that EOF When defining messages in this way, longer templates may be broken-up (as shown on the third line of the example above) by placing one or more dots (C<.>) where a message id would normally appear. This forces the text fragment on the right to be appended to the template above, separated by a single space. Similarly, the addition symbol (C<+>) may be used in place of dot(s) if a newline is desired as the separator. This is particularly helpful when using PerlTidy and shorter line lengths. =back Multiple sets of export options and message groups may be added to the same import method's argument list: use message ':MESSAGES, :MISC' => ( INF_GREETING => "I am completely operational, " . "and all my circuits are functioning perfectly.", RSP_DO_WHAT => "What would you have me do?\n", ), ':MESSAGES, :NOTICES' => ( NTC_FAULT => "I've just picked up a fault in the %s unit.", ), ':MESSAGES, :ERRORS' => ( CRT_NO_CAN_DO => "I'm sorry, %s. I'm afraid I can't do that", ); When a message group has been processed any export related options that are currently in force will be reset; no further messages will be marked as exportable until a new set of export options and messages is added to the same directive. Pay attention when defining messages as simple lists of key-value pairs, as any new export option(s) will punctuate a list of messages up to that point and they will be processed as a complete group. The message parser will also substitute the following escape sequences with the correct character shown in parentheses: =over =item * C<\n> (newline) =item * C<\r> (linefeed) =item * C<\t> (tab) =item * C<\a> (bell) =item * C<\s> (space) =back =head3 id MESSAGE_ID->id; Gets the message's identifier. =head3 level MESSAGE_ID->level( $severity_int ); MESSAGE_ID->level( $long_or_short_type_str ); $severity_int = MESSAGE_ID->level; Sets or gets a message's severity level. The severity level is always returned as an integer value, while it may be set using an integer value or a type code (long or short) with the desired value. =over =item B<Example> # Give my notice a higher severity, equivalent to a warning. NTC_FAULT->level(4); NTC_FAULT->level('W'); NTC_FAULT->level('WARNING'); =back (See L<MESSAGE TYPES> for more informtion about typing.) =head3 output $formatted_message_str = MESSAGE_ID->output; Returns the formatted text produced last time a particular message was used, or it returnd C<undef> if the message hasn't yet been issued. The message's C<output> value would also include the values of any parameters passed to the message. =over =item B<Example> # Package in which messages are defined. # package My::App::MsgRepo; use Message::String EXPORT_OK => { NTC_FAULT => 'I've just picked up a fault in the %s unit.', }; 1; # Package in which messages are required. # use My::App::MsgRepo qw/NTC_FAULT/; use Test::More; NTC_FAULT('AE-35'); # The message is issued... # Some time later... diag NTC_FAULT->output; # What was the last reported fault again? # Output: # I've just picked up a fault in the AE-35 unit. =back =head3 readmode MESSAGE_ID->readmode( $mode_str ); MESSAGE_ID->readmode( $mode_int ); $mode_int = MESSAGE_ID->readmode; Uses L<C<Term::ReadKey>> to set the terminal driver mode when getting the response from C<STDIN>. The terminal driver mode is restored to its C<normal> state after the input is complete. Ostensibly, this method is intended for use with Type R (Response) messages, specifically to switch off TTY echoing for password entry. You should, however, never need to use explicitly if the text I<"password"> is contained within the message's template, as its use is implied. =over =item B<Example> RSP_MESSAGE->readmode('noecho'); =back =head3 response $response_str = MESSAGE_ID->response; Returns the input given in response to the message last time it was used, or it returns C<undef> if the message hasn't yet been isssued. The C<response> accessor is only useful with Type R (Response) messages. =over =item B<Example> # Package in which messages are defined. # package My::App::MsgRepo; use Message::String EXPORT_OK => { INF_GREETING => 'Welcome to the machine.', RSP_USERNAME => 'Username: ', RSP_PASSWORD => 'Password: ', }; # Since RSP_PASSWORD is a response and contains the word "password", # the response is not echoed to the TTY. # # RSP_PASSWORD->readmode('noecho') is implied. 1; # Package in which messages are required. # use My::App::MsgRepo qw/INF_GREETING RSP_USERNAME RSP_PASSWORD/; use DBI; INF_GREETING; # Pleasantries RSP_USERNAME; # Prompt for and fetch username RSP_PASSWORD; # Prompt for and fetch password $dbh = DBI->connect( 'dbi:mysql:test;host=127.0.0.1', RSP_USERNAME->response, RSP_PASSWORD->response ) or die $DBI::errstr; =back =head3 severity MESSAGE_ID->severity( $severity_int ); MESSAGE_ID->severity( $long_or_short_type_str ); $severity_int = MESSAGE_ID->severity; (An alias for the C<level> method.) =head3 template MESSAGE_ID->template( $format_or_text_str ); $format_or_text_str = MESSAGE_ID->template; Sets or gets the message template. The template may be a plain string of text, or it may be a C<sprintf> format containing parameter placeholders. =over =item B<Example> # Redefine our message templates. INF_GREETING->template('Ich bin völlig funktionsfähig, und alle meine ' . 'Schaltungen sind perfekt funktioniert.'); CRT_NO_CAN_DO->template('Tut mir leid, %s. Ich fürchte, ich kann das ' . 'nicht tun.'); # Some time later... INF_GREETING; CRT_NO_CAN_DO('Dave'); =back =head3 to_string $output_or_template_str = MESSAGE_ID->to_string; Gets the string value of the message. If the message has been issued then you get the message output, complete with any message parameter values. If the message has not yet been issued then the message template is returned. Message objects overload the stringification operator ("") and it is this method that will be called whenever the string value of a message is required. =over =item B<Example> print INF_GREETING->to_string . "\n"; # Or, embrace your inner lazy: print INF_GREETING . "\n"; =back =head3 type MESSAGE_ID->type( $long_or_short_type_str ); $short_type_str = MESSAGE_ID->type; Gets or sets a message's type characteristics, which includes its severity level. =over =item B<Example> # Check my message's type $code = NTC_FAULT->type; # Returns "N" # Have my notice behave more like a warning. NTC_FAULT->type('W'); NTC_FAULT->type('WARNING'); =back =head3 verbosity MESSAGE_ID->type( $severity_int ); MESSAGE_ID->type( $long_or_short_type_str ); $severity_int = MESSAGE_ID->verbosity; Gets or sets the level above which messages will B<not> be issued. Messages above this level may still be generated and their values are still usable, but they are silenced. I<You cannot set the verbosity level to a value lower than a standard Type E (Error) message.> =over =item B<Example> # Only issue Alert, Critical, Error and Warning messages. message->verbosity('WARNING'); # Or ... message->verbosity('W'); # Or ... message->verbosity(4); =back =head3 overloaded "" $output_or_template_str = MESSAGE_ID; Message objects overload Perl's I<stringify> operator, calling the C<to_string> method. =head1 MESSAGE TYPES Messages come in an nine great flavours, each identified by a single-letter type code. A message's type represents the severity of the condition that would cause the message to be issued: =head3 Type Codes Type Alt Level / Type Code Type Priority Description ---- ---- -------- --------------------- A ALT 1 Alert C CRT 2 Critical E ERR 3 Error W WRN 4 Warning N NTC 5 Notice I INF 6 Info D DEB 7 Debug (or diagnostic) R RSP 1 Response M MSG 6 General message =head2 How messages are assigned a type When a message is defined an attempt is made to discern its type by examining it for a series of clues: =over =item B<Step 1>: check for a suffix matching C</:([DRAWNMICE])$/> The I<type override> suffix spoils the fun by removing absolutely all of the guesswork from the process of assigning type characteristics. It is kind of ugly but removes absolutely all ambiguity. It is somewhat special in that it does not form part of the message's identifier, which is great if you have to temporarily re-type a message but don't want to hunt down and change every occurrence of its use. This suffix is a great substitute for limited imaginative faculties when naming messages. =item B<Step 2>: check for a suffix matching C</[_\d]([WINDCREAM])$/> This step, like the following three steps, uses information embedded within the identifier to determine the type of the message. Since message ids are meant to be mnemonic, at least some attempt should be made by message authors to convey purpose and meaning in their choice of id. =item B<Step 3>: check for a prefix matching C</^([RANCIDMEW])[_\d]/> =item B<Step 4>: check for a suffix matching C</(I<ALTERNATION>)$/>, where the alternation set is comprised of long type codes (see L<Long Type Codes>). =item B<Step 5>: check for a prefix matching C</^(I<ALTERNATION>)/>, where the alternation set is comprised of long type codes (see L<Long Type Codes>). =item B<Step 6>: as a last resort the message is characterised as Type-M (General Message). =back =head3 Long Type Codes In addition to having a single-letter type code, longer type code aliase may be used to describe their types. In fact, the public interface often allows for the use of the longer type code aliases where a type code may be used for reasons of clarity. We can use one of this package's protected methods (C<_types_by_alias>) to not only list the type code aliases but to reveal type code equivalence: use Test::More; use Data::Dumper::Concise; use Message::String; diag Dumper( { message->_types_by_alias } ); # { # ALERT => "A", # ALR => "A", # ALT => "A", # CRIT => "C", # CRITICAL => "C", # CRT => "C", # DEB => "D", # DEBUG => "D", # DGN => "D", # DIAGNOSTIC => "D", # ERR => "E", # ERROR => "E", # FATAL => "C", # FTL => "C", # INF => "I", # INFO => "I", # INP => "R", # INPUT => "R", # MESSAGE => "M", # MISC => "M", # MSC => "M", # MSG => "M", # NOT => "N", # NOTICE => "N", # NTC => "N", # OTH => "M", # OTHER => "M", # OTR => "M", # PRM => "R", # PROMPT => "R", # RES => "R", # RESPONSE => "R", # RSP => "R", # WARN => "W", # WARNING => "W", # WNG => "W", # WRN => "W" # } =head2 Changing a message's type Under exceptional conditions it may be necessary to alter a message's type, and this may be achieved in one of three ways: =over =item 1. I<Permanently,> by choosing a more suitable identifier. This is the cleanest way to make such a permanent change, and has only one disadvantage: you must hunt down code that uses the old identifier and change it. Fortunately, C<grep> is our friend and constants are easy to track down. =item 2. I<Semi-permanently,> by using a type-override suffix. # Change NTC_FAULT from being a notice to a response, so that it # blocks for input. We may still use the "NTC_FAULT" identifier. use message << 'EOF'; NTC_FAULT:R I've just picked up a fault in the %s unit. EOF Find the original definition and append the type-override suffix, which must match regular expression C</:[CREWMANID]$/>, obviously being careful to choose the correct type code. This has a cosmetic advantage in that the suffix will be effective but not be part of the the id. The disadvantage is that this can render any forgotten changes invisible, so don't forget to change it back when you're done. =item 3. I<Temporarily,> at runtime, using the message's C<type> mutator: # I'm debugging an application and want to temporarily change # a message named APP234I to be a response so that, when it displays, # it blocks waiting for input - APP234I->type('R'); # Or, ... APP234I->type('RSP'); # Possibly much clearer, or ... APP234I->type('RESPONSE'); # Clearer still =back =head1 WHISTLES, BELLS & OTHER DOODADS =head2 Customising message output =head3 Embedding timestamps MESSAGE_ID->_default_timestamp_format($strftime_format_str); MESSAGE_ID->_type_timestamp($type_str, ''); MESSAGE_ID->_type_timestamp($type_str, 1); MESSAGE_ID->_type_timestamp($type_str, $strftime_format_str); MESSAGE_ID->_type_timestamp(''); MESSAGE_ID->_type_timestamp(1); =head3 Embedding type information MESSAGE_ID->_type_tlc($type_str, ''); MESSAGE_ID->_type_tlc($type_str, $three_letter_code_str); =head3 Embedding the message id MESSAGE_ID->_type_id($type_str, $bool); MESSAGE_ID->_type_id($bool); =head1 ACKNOWLEDGEMENTS Standing as we all do from time to time on the shoulders of giants: =over =item Dave RolskyI<, et al.> For L<DateTime> =item Eric Brine For L<Syntax::Feature::Void>. =item Graham BarrI<, et al.> For L<Scalar::Util> and L<Sub::Util> =item Jens ReshackI<, et al.> For L<List::MoreUtils>. =item Jonathon Stowe & Kenneth Albanowski For L<Term::ReadKey>. =item Ray Finch For L<Clone> =item Robert SedlacekI<, et al.> For L<namespace::clean> =back =head1 AUTHOR Iain Campbell <cpanic@cpan.org> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Iain Campbell. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut |