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