lib/Language/Befunge/Debug.pm

   1 #
   2 # This file is part of Language::Befunge.
   3 # Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the same terms as Perl itself.
   7 #
   8 #
   9
  10 package Language::Befunge::Debug;
  11
  12 use 5.010;
  13 use strict;
  14 use warnings;
  15
  16 use base qw{ Exporter };
  17 our @EXPORT = qw{ debug };
  18
  19
  20 # -- public subs
  21
  22 sub debug {}
  23
  24 my %redef;
  25 sub enable {
  26     %redef = ( debug => sub { warn @_; } );
  27     _redef();
  28 }
  29
  30 sub disable {
  31     %redef = ( debug => sub {} );
  32     _redef();
  33 }
  34
  35
  36 # -- private subs
  37
  38 #
  39 # _redef()
  40 #
  41 # recursively walk the symbol table, and replace subs named after %redef
  42 # keys with the matching value of %redef.
  43 #
  44 # this is not really clean, but since the sub debug() is exported in
  45 # other modules, replacing the sub in *this* module is not enough: other
  46 # modules still refer to their local copy.
  47 #
  48 # also, calling sub with full name Language::Befunge::Debug::debug() has
  49 # performance issues (10%-15%) compared to using an exported sub...
  50 #
  51 my %orig; # original subs
  52 sub _redef {
  53     my $parent = shift;
  54     if ( not defined $parent ) {
  55         $parent = '::';
  56         foreach my $sub ( keys %redef ) {
  57             $orig{ $sub } = \&$sub;
  58         }
  59     }
  60     no strict   'refs';
  61     no warnings 'redefine';
  62     foreach my $ns ( grep /^\w+::/, keys %{$parent} ) {
  63         $ns = $parent . $ns;
  64         _redef($ns) unless $ns eq '::main::';
  65         foreach my $sub (keys %redef) {
  66             next                                       # before replacing, check that...
  67                 unless exists ${$ns}{$sub}             # named sub exist...
  68                 && \&{ ${$ns}{$sub} } == $orig{$sub};  # ... and refer to the one we want to replace
  69             *{$ns . $sub} = $redef{$sub};
  70         }
  71     }
  72 }
  73
  74 1;
  75
  76 __END__
  77
  78 =head1 NAME
  79
  80 Language::Befunge::Debug - optimized debug solution for language::befunge
  81
  82
  83 =head1 SYNOPSIS
  84
  85     use Language::Befunge::Debug;
  86     debug("foo\n");     # does nothing by default
  87     Language::Befunge::Debug::enable();
  88     debug("bar\n");     # now that debug is enabled, output on STDERR
  89     Language::Befunge::Debug::disable();
  90     debug("baz\n");     # sorry dave, back to no output
  91
  92
  93
  94 =head1 DESCRIPTION
  95
  96 This module provides a C<debug()> subroutine, which output on STDERR if
  97 debugging is enabled. If debugging is disabled (the default), perl will
  98 optimize out those debugging calls.
  99
 100
 101
 102 =head1 PUBLIC API
 103
 104 =head2 Exported functions
 105
 106 The module is exporting only one function:
 107
 108 =over 4
 109
 110 =item * debug( @stuff );
 111
 112 If debugging is enabled (which is B<not> the default), write C<@stuff>
 113 on STDERR.
 114
 115 =back
 116
 117
 118 =head2 Other functions
 119
 120 The module also provides 2 functions to control debugging:
 121
 122 =over 4
 123
 124 =item * Language::Befunge::Debug::enable();
 125
 126 Request that calls to C<debug()> really start output on STDERR.
 127
 128
 129 =item * Language::Befunge::Debug::disable();
 130
 131 Request that calls to C<debug()> stop output-ing on STDERR.
 132
 133
 134 =back
 135
 136
 137
 138 =head1 SEE ALSO
 139
 140 L<Language::Befunge>
 141
 142
 143
 144 =head1 AUTHOR
 145
 146 Jerome Quelin, C<< <jquelin@cpan.org> >>
 147
 148 Development is discussed on C<< <language-befunge@mongueurs.net> >>
 149
 150
 151
 152 =head1 COPYRIGHT & LICENSE
 153
 154 Copyright (c) 2001-2009 Jerome Quelin, all rights reserved.
 155
 156 This program is free software; you can redistribute it and/or modify
 157 it under the same terms as Perl itself.
 158
 159
 160 =cut
 161