File Coverage

File:lib/Message/String.pm
Coverage:95.1%

linestmtbrancondsubpodtimecode
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
4package 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
17BEGIN {
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.
692sub _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.
714sub _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.
738sub _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.
753sub _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.
768sub _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.
790sub _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.
803sub _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.
824sub _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.
852sub 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.
864sub 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.
876sub 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.
890sub 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.
898sub 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).
911sub 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.
935sub 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.
959sub _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.
983sub _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.
992sub _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.
1001sub _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.
1021sub 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
1129use 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
11361;
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