1package Devel::Messenger;
2
3use strict;
4use vars qw($VERSION @ISA @EXPORT @EXPORT_OK @trap);
5
6require Exporter;
7
8@ISA = qw(Exporter);
9@EXPORT_OK = qw(note);
10@EXPORT = ();
11$VERSION = '0.02';
12local @trap = ();
13
14sub note {
15    return _initialize({}, shift, "Using Devel::Messenger version $VERSION\n", @_) if (ref($_[0]) eq 'HASH');
16    return '';
17}
18
19sub _initialize {
20    my $prev  = shift; # HASH ref
21    my $opts = shift; # HASH ref
22    # inherit from previous opts
23    foreach my $key (keys %$prev) {
24        $opts->{$key} = $prev->{$key} unless exists($opts->{$key});
25    }
26    # suppress version announcement
27    my $quiet = defined($opts->{quiet}) ? $opts->{quiet} : 0;
28    shift if ($quiet and @_ and substr($_[0], 0, 31) eq 'Using Devel::Messenger version ');
29    # output function to use
30    my $output = '_' . ($opts->{output} || 'none');
31    # filename or filehandle
32    my $file = '';
33    if (defined($opts->{output}) and ref($opts->{output})) {
34        $output = '_handle';
35        $file = $opts->{output};
36    } elsif (!defined(&{"Devel::Messenger::$output"})) {
37        $output = '_file';
38        $file = $opts->{output};
39    }
40    # level of debugging (0 for unlimited)
41    my $level = (defined($opts->{level}) and ($opts->{level} =~ m/^\d$/)) ? $opts->{level} : 1;
42    # prefix function for each line
43    my $prefix  = '';
44    my $pkgname = $opts->{pkgname} || 0;
45    my $linenum = $opts->{linenumber} || 0;
46    if ($pkgname) {
47        if ($linenum) {
48            $prefix = '_prefix';
49        } else {
50            $prefix = '_prefix_name';
51        }
52    } elsif ($linenum) {
53        $prefix = '_prefix_line';
54    }
55    # text to wrap around each note
56    my ($begin, $end) = _wrapper($opts->{wrap} || '');
57    # globalize new subroutine definition?
58    my $global = $opts->{global} || 0;
59    # set up CODE ref to return
60    my $note = sub {
61        return _initialize($opts, @_) if (ref($_[0]) eq 'HASH');
62        my $debug = (ref($_[0]) eq 'SCALAR' ? ${shift()} : 1);
63        return '' if ($output eq '_none');
64        return '' if ($debug > $level and $level);
65        no strict 'refs';
66        &$output($file, splice @trap) if (@trap and $output ne '_trap');
67        my $pre = $prefix;
68        my @message = grep { defined($_) } @_;
69        if (@message and $message[0] eq 'continue') {
70            shift @message;
71            $pre = '';
72        }
73        return '' unless @message;
74        chomp($message[$#message]) if (substr($end, -1, 1) eq "\n");
75        &$output($file, $begin, ($pre ? &$pre(caller) : ''), @message, $end);
76    };
77    # export subroutine
78    if ($global) {
79        #my $caller = (caller)[0];
80        foreach my $pkg (sort grep { $_ ne 'Devel/Messenger.pm' } 'main', keys %INC) {
81            (my $module = $pkg) =~ s/\.pm$//;
82            $module =~ s/\//::/g;
83            if (defined(&{"$module\::note"})) {
84                no strict 'refs';
85                #undef &{"$module\::note"} unless ($module eq $caller);
86                *{"$module\::note"} = $note;
87            }
88        }
89    }
90    # note anything needful
91    &$note(@_) if (@_ or (@trap and $output ne '_trap'));
92    return $note;
93}
94
95# --------------------------- N O T E - M A R K U P -------------------------- #
96
97sub _prefix {
98    my ($package, $filename, $line) = @_;
99    my ($pkgname) = _prefix_name($package, $filename, $line);
100    my ($linenum) = _prefix_line($package, $filename, $line);
101    return ($pkgname, ' '.$linenum, ': ');
102}
103
104sub _prefix_name {
105    my ($package, $filename, $line) = @_;
106    return (($package eq 'main' ? $filename : $package), ': ');
107}
108
109sub _prefix_line {
110    my ($package, $filename, $line) = @_;
111    return ("($line)", ': ');
112}
113
114sub _wrapper {
115    if (ref($_[0]) eq 'ARRAY') {
116        return @{shift()};
117    } else {
118        my $wrapping = shift;
119        return ($wrapping, $wrapping);
120    }
121}
122
123# ---------------------- O U T P U T - F U N C T I O N S --------------------- #
124
125sub _file {
126    my $file = shift;
127    if (open NOTE, ">>$file") {
128        print NOTE @_;
129        close NOTE;
130    } else {
131        warn "Cannot append to file $file: $!\n";
132    }
133}
134
135sub _handle {
136    my $file = shift;
137    print $file @_;
138}
139
140sub _print  { local $| = 1; shift; print @_; }
141
142sub _warn   { shift; warn @_; }
143
144sub _return { shift; return @_ if wantarray; join('', @_); }
145
146sub _trap   { shift; push @trap, @_; return ''; }
147
148sub _none   {}
149
1501;
151
152__END__
153
154=head1 NAME
155
156Devel::Messenger - Let Your Code Talk to You
157
158=head1 SYNOPSIS
159
160  use Devel::Messenger qw{note};
161
162  # set up localized subroutine
163  local *note = Devel::Messenger::note {
164      output     => 'print',
165      level      => 2,
166      pkgname    => 1,
167      linenumber => 1,
168      wrap       => ["<!--", "-->\n"],
169  };
170
171  # print a note
172  note "This is a sample note\n";
173
174  # print a multipart note
175  note "This is line two. ";
176  note "continue", "This is still line two.\n";
177
178  # print if 'level' is high enough
179  note \2, "This is debug level two\n";
180
181=head1 DESCRIPTION
182
183Do you want your program to tell you what it is doing? Send this messenger
184into the abyss of your code to bring back to you all the pertinent information
185you want.
186
187First, set notes in your code, in-line comments that start with C<note>
188instead of C<#>.
189
190    # this is an in-line comment (it is boring)
191    note "this is a note (things start getting exciting now)\n";
192
193To keep your program from giving you terrible errors about C<note> not
194being defined, give it something to do.
195
196  use subs qw{note};
197  sub note {}
198
199Or you could import the slightly more powerful C<note> subroutine defined
200in Devel::Messenger.
201
202  use Devel::Messenger qw{note};
203
204By itself, C<note> does not do anything. Right now, all it is doing is
205making sure Perl doesn't give you an error message and die.
206
207So how do you make Devel::Messenger go and activate these notes?
208
209=head2 Specify What You Want Your Messenger to Do
210
211Devel::Messenger wants to help you and your code talk to each other. It
212will act as a messenger between you both.
213
214First, you tell Devel::Messenger which notes to talk to, and how you want
215it to return messages to you. Then, it goes off and starts negotiating with
216your code.
217
218Use Devel::Messenger's own C<note> subroutine to specify your instructions.
219
220  local *note = Devel::Messenger::note \%instructions;
221
222Your instructions must be in the form of a HASH reference for Devel::Messenger
223to understand you. You may wish to use an anonymous HASH reference.
224
225  local *note = Devel::Messenger::note {
226      output => 'print',
227      level  => 2,
228  };
229
230Here, we have told our messenger to C<print> any notes which are specified
231as level one or level two, which appear in the current package. When you
232run your code, Devel::Messenger will look for notes that match your
233instructions. Any notes that match those criteria will be printed via the
234Perl function C<print>.
235
236You may also request Devel::Messenger to look for notes in other packages.
237
238  local *Other::Module::note = Devel::Messenger::note {
239      output => 'print',
240      level  => 2,
241  };
242
243If you are going to search for notes in multiple packages, it might be
244easier to capture the instructions in a SCALAR, then use the SCALAR in
245several places.
246
247  my $note = Devel::Messenger::note {
248      output => 'print',
249      level  => 2,
250  };
251
252  local *note = $note;
253  local *Other::Module::note = $note;
254
255You may have noticed that I have been using the Perl function C<local> in
256all my GLOB assignments. This is not necessary. In fact, it can be downright
257annoying at times. Do it anyway.
258
259If you are using the Perl module C<warnings>, or are running Perl with
260the C<-w> switch, every time you redefine a subroutine, a warning is
261generated. Using C<local> avoids these errors.
262
263If you are running any of your code under C<mod_perl>, having a globally
264assigned subroutine for debugging can cause other C<mod_perl> copies of
265your code to also be sending you debugging information. That gets nasty.
266Using C<local> avoids this problem.
267
268However, when you use C<local>, you must be careful that your C<note>
269definition stays in scope for as long as you wish it to. Otherwise,
270Devel::Messenger will forget what it is doing and go back to sleep. In
271object-oriented programming, you may wish to store your instructions in
272your object.
273
274  my $self = bless {};
275  $self->{note} = Devel::Messenger::note {
276      output => 'print',
277      level  => 2,
278  };
279  $self->{note}->("This is my note\n");
280  local *note = $self->{note};
281  note "This is also my note\n";
282
283=head2 Nitty-Gritty
284
285Your instructions to C<Devel::Messenger::note> must be in a HASH reference.
286The keys of that HASH instruct Devel::Messenger to do different things.
287
288=over 4
289
290=item global
291
292If you want notes from all the modules you are using, and you are not
293worried about global subroutine definitions or "subroutine redefined"
294warnings, you may wish to specify that you want to search for all notes.
295
296  note { global => 1 };
297
298This will search %INC and replace any defined C<note> subroutine with the
299new definition. If you have other subroutines named C<note>, they will be
300overridden.
301
302=item level
303
304Set how much debugging you want. The bigger the number, the more verbose
305(except zero, which is unlimited).
306
307A note can specify what level it is.
308
309  note "This is level one\n";
310  note \1, "This is also level one\n";
311  note \2, "This is level two\n";
312  note \3, "This is level three\n";
313
314By setting the C<level> you want, Devel::Messenger will know to ignore
315notes with a higher level than you specified.
316
317=item linenumber
318
319Sometimes it is useful to know where a note came from. This setting will
320prepend the linenumber to the messages Devel::Messenger finds for you.
321
322See also C<pkgname>.
323
324=item output
325
326If you do not tell Devel::Messenger what to do with your messages, it will
327just ignore them. You can specify where to send them by setting this
328instruction.
329
330There are several ways Devel::Messenger can try to send you messages. These
331are described below:
332
333=over 8
334
335=item file
336
337Internal use only.
338
339=item handle
340
341Internal use only.
342
343=item none
344
345Abandons your note.
346
347=item print
348
349Sends your note to the perl subroutine 'print'.
350
351=item return
352
353Returns your note to you (you will have to grab it).
354
355  local *note = Devel::Messenger::note { output =>'return' };
356  $text = note "This is my note\n";
357
358=item trap
359
360Traps your notes until you set your output to something else, at which
361time the trapped notes are sent to the newly designated output. Sending
362to C<return> will abandon any trapped notes.
363
364  local *note = Devel::Messenger::note { output => 'trap' };
365  note "This note is trapped for a while\n";
366  local *note = note { output => 'print' };
367
368Notice that I did not send instructions to Devel::Messenger when I was
369finished trapping notes. Any C<note> subroutine created by Devel::Messenger
370knows how to take new instructions. In this case, the trapped notes will
371be forgotten unless you give new instructions to the same subroutine that
372trapped the notes originally.
373
374=item warn
375
376Sends your note to the perl subroutine 'warn'.
377
378=item a FILEHANDLE
379
380Prints your note to a filehandle.
381
382  open FILE, '>file.txt' or die $!;
383  local *note = Devel::Messenger::note { output => \*FILE };
384  note "This is my note\n";
385  close FILE;
386
387=item a file name
388
389Appends each note to a file.
390
391  local *note = Devel::Messenger::note {output =>'file.txt'};
392  note "This is my note\n";
393
394Any string specified as a value for C<output>, which is not listed above,
395is interpretted as a file name. A warning is issued if the file cannot
396be opened for appending.
397
398=back
399
400=item pkgname
401
402If you want to know from which package a note is coming, you can have
403Devel::Messenger prepend the package name to each message. If the note is
404coming from package "main" (the default package), the filename shall be
405prepended instead.
406
407If this is not enough information, you may also want to ask for a C<linenumber>
408to be provided.
409
410=item quiet
411
412When you instruct C<Devel::Messenger::note>, it tries to send you a message
413telling you which version of Devel::Messenger you are using. You may not
414wish to fill up your error log, or other files, with this version information.
415In this case, you should tell Devel::Messenger to keep quiet about what
416version it is.
417
418  note { quiet => 1 };
419
420=item wrap
421
422Devel::Messenger likes to give you messages how you like them. With this
423option, you can specify markup you wish to have wrapped around each note.
424Accepts an ARRAY reference or a string.
425
426  local *note = Devel::Messenger::note { wrap => ["<!--", "-->\n"] };
427  note "This is an HTML comment\n";
428  # <!--This is an HTML comment-->\n
429
430  local *note = Devel::Messenger::note { wrap => '###' };
431  note "help!";
432  # ###help!###
433
434If the second part of the wrapping text ends in a newline (\n), the note
435is chomped before being wrapped.
436
437=back
438
439=head2 Common Debug Levels
440
441As explained above, notes can specify what level they are. The level could
442theoretically be from one all the way up to your integer limit.
443
444However, levels could become almost meaningless if we allowed so many
445different levels.
446
447My standard levels are:
448
449=over 4
450
451=item 1
452
453Minimal information about what the program is doing.
454
455=item 2
456
457Database interaction: connections, queries, number of records returned,
458et cetera.
459
460=item 3
461
462In depth information about what the program is doing.
463
464=item 4
465
466In depth information about database interaction.
467
468=item 5
469
470In depth information about formatting.
471
472=item 6
473
474In depth information about conversions.
475
476=item 7
477
478In depth information about everything else.
479
480=back
481
482=head1 AUTHOR
483
484Nathan Gray - kolibrie@southernvirginia.edu
485
486=head1 COPYRIGHT
487
488Devel::Messenger is Copyright (c) 2001 Nathan Gray.
489All rights reserved.
490
491You may distribute under the terms of either the GNU General
492Public License, or the Perl Artistic License.
493
494=cut
495