File Coverage

lib/Log/Shiras/Unhide.pm
Criterion Covered Total %
statement 124 133 93.2
branch 24 34 70.5
condition 4 11 36.3
subroutine 20 20 100.0
pod n/a
total 172 198 86.8


line stmt bran cond sub pod time code
1             package Log::Shiras::Unhide;
2             our $AUTHORITY = 'cpan:JANDREW';
3 2     2   314327 use version; our $VERSION = version->declare("v0.44.0");
  2         2840  
  2         10  
4 2     2   123 use utf8;
  2         2  
  2         9  
5 2     2   48 use 5.010;
  2         8  
6 2     2   5 use strict;
  2         3  
  2         25  
7 2     2   6 use warnings;
  2         2  
  2         61  
8             # [rt.cpan.org #84818]
9 2     2   970 use if $^O eq "MSWin32", "Win32";
  2         14  
  2         8  
10              
11 2     2   1330 use File::Temp;# qw(tempfile);
  2         23281  
  2         153  
12             #~ $File::Temp::DEBUG = 1;
13 2     2   14 use File::Spec;
  2         3  
  2         51  
14 2     2   636 use Module::Runtime qw( require_module );
  2         1335  
  2         16  
15 2     2   589 use Data::Dumper;
  2         4864  
  2         90  
16             use lib
17 2         10 '../../../lib',
18 2     2   8 ;
  2         3  
19              
20 2     2   156 use constant IMPORT_DEBUG => 0; # Unhide Dev testing only
  2         3  
  2         98  
21 2     2   6 use constant INTERNAL_DEBUG => 0; # Unhide Dev testing only
  2         2  
  2         73  
22 2     2   5 use constant VIEW_TRANSFORM => 0; # Unhide Dev testing only
  2         1  
  2         2088  
23             my $my_unhide_skip_check = qr/(
24             ^Archive.Zip| ^attributes| ^AutoLoader| ^B\.pm|
25             ^B.(Op_|Deparse)| ^B.(Hooks)| ^Carp| ^Class|
26             ^Clone| ^common| ^Compress.Raw| ^Cwd|
27             ^Data.OptList| ^DateTime(?!X)| ^Devel| ^Encode|
28             ^Eval| ^Exporter| ^feature| ^File|
29             ^Filter| ^if\.pm| ^integer| ^IO.File|
30             ^JSON| ^List| ^Log.Shiras.Unhide| ^metaclass|
31             ^Module| ^Moose(?!X)| ^MooseX.Has| ^MooseX.Non|
32             ^MooseX.Singleton| ^MooseX.Strict| ^MooseX.Type| ^MRO|
33             ^namespace| ^Package| ^Params| ^parent|
34             ^PerlIO| ^POSIX| ^re\.pm| ^SelfLoader|
35             ^SetDual| ^Smart| ^Sub| ^Test2|
36             ^Tie| ^Text| ^Time.Local| ^Try|
37             ^Type| ^unicore| ^UNIVERSAL| ^utf8|
38             ^Variable| ^Win32| ^XML|
39             ^YAML
40             )/x;
41             my $run_once_hash;
42             our $strip_match;
43             my $temp_dir;
44              
45              
46             #########1 import 2#########3#########4#########5#########6#########7#########8#########9
47              
48             sub import {
49 3     3   14 my( $class, @args ) = @_;
50             # Handle re-call
51 3 100       10 if( $strip_match ){
52 1         1 warn "------------>Trying to reload Unhide with string: $strip_match !!!!!!!!!\n" if IMPORT_DEBUG;
53 1         4 _resurrector_init();
54 1         11 return 1;
55             }
56              
57 2 50 50     13 warn "Received args:" . join( '~|~', @args ) if @args and IMPORT_DEBUG;
58              
59             # Build a temporary directory
60 2         11 $temp_dir = File::Temp->newdir( CLEANUP => 1 );
61              
62             # Handle versions
63 2 50 33     926 if( $args[0] and $args[0] =~ /^v?\d+\.?\d*/ ){# Version check since import highjacks the built in
64 0         0 warn "Running version check on version: $args[0]" if IMPORT_DEBUG;
65 0         0 my $result = $VERSION <=> version->parse( $args[0]);
66 0         0 warn "Tested against version -$VERSION- gives result: $result" if IMPORT_DEBUG;
67 0 0       0 if( $result < 0 ){
68 0         0 die "Version -$args[0]- requested for Log::Shiras::Switchboard " .
69             "- the installed version is: $VERSION";
70             }
71 0         0 shift @args;
72             }
73              
74             # Build/Load the string strippers
75 2         4 my @strip_list;
76 2         3 for my $flag ( @args ){
77 5         5 warn "Arrived at import with flag: $flag" if IMPORT_DEBUG;
78 5 50       14 if( $flag =~ /^:([A-Za-z]+)$/ ){# Handle text based flags
79 5         10 my $strip = $1;
80 5 100       11 push @strip_list, $strip eq 'debug' ? 'LogSD' : $strip;
81             }else{
82 0         0 die "Flag -$flag- passed to import Log::Shiras::Switchboard did not pass the format test.";
83             }
84             }
85              
86             # Implement string stripping
87 2 50       5 if( @strip_list ){
88 2         7 $strip_match = '(' . join( '|', @strip_list ) . ')';
89 2 100       58 warn "Using Log::Shiras::Unhide-$VERSION strip_match string: $strip_match" if !$ENV{hide_warn};
90 2         925 _resurrector_init();
91 2         11 $ENV{loaded_filter_util_call} = 1;
92             # Check for Filter::Util::Call availability
93 2         2 warn "Attempting to strip leading qr/###$Log::Shiras::Unhide::strip_match/" if IMPORT_DEBUG;
94 2         2 my $FILTER_MODULE = "Filter::Util::Call";
95 2         2 my $require_result;
96 2         3 eval{ $require_result = require_module( 'Filter::Util::Call' ) };# require_module( $FILTER_MODULE ) };#
  2         6  
97 2 50 33     1437 if( $require_result and ($require_result == 1 or $require_result eq $FILTER_MODULE) ) {
      33        
98 2         8 $ENV{loaded_filter_util_call} = 1;
99             # Strip the top level script
100             Filter::Util::Call::filter_add(
101             sub {
102 162     162   204 my $status;
103 162 100       430 if($status = Filter::Util::Call::filter_read() > 0 ){
104 160         370 s/^(\s*)###$Log::Shiras::Unhide::strip_match\s/$1/mg;
105             }
106 162         92 warn "----->script scrubbed line : $_" if VIEW_TRANSFORM;
107 162         6440 $status;
108             }
109 2         11 );
110             }else{
111 0         0 warn "$FILTER_MODULE required to strip the script. The flags |" . join( ' ', @args ) .
112             "| will only be implemented for 'use'd modules - ('cpan Filter::Util::Call' to install)";
113             }
114             }
115             }
116              
117             #########1 Functional Startup Private Methods 5#########6#########7#########8#########9
118              
119             sub _resurrector_init {
120 3     3   13 unshift @INC, \&_resurrector_loader;
121             }
122              
123             sub _resurrector_loader {
124              
125 216     216   1384367 my ($code, $module) = @_;
126              
127 216         222 warn "$module sent to source filter scrub\n" if INTERNAL_DEBUG;
128              
129             # Skip Stuff that isn't likely to have source filter flags
130 216 100       2782 if($module =~ $my_unhide_skip_check) {
131 164         182 warn "Don't scrub |$module| (it's on the skip list) return undef" if INTERNAL_DEBUG;
132 164         84330 return undef;
133             }else{
134 52         54 warn "Scrubbing Module: $module\n" if INTERNAL_DEBUG;;
135             }
136              
137 52         53 my $path = $module;
138 52         56 warn "Finding the location of module: $module" if INTERNAL_DEBUG;
139              
140             # Skip unknown files
141 52 50       392 if(!-f $module) {
142             # We might have a 'use lib' statement that modified the
143             # INC path, search again.
144 52         86 $path = _pm_search($module);
145 52 100       112 if(! defined $path) {
146 1         1 warn "File $module not found" if INTERNAL_DEBUG;
147 1         117 return undef;
148             }
149 51         38 warn "File $module found in $path" if INTERNAL_DEBUG;
150             }
151              
152 51         32 warn "Unhiding debug in module $path" if INTERNAL_DEBUG;
153 51         38 my $fh;
154 51 50       127 if( exists $run_once_hash->{$path} ){
155 0         0 warn "No action since this is already done" if INTERNAL_DEBUG;
156             }else{
157 51         77 $fh = _resurrector_fh($path);
158 51         133 $run_once_hash->{$path} = 1;
159             }
160              
161 51         663 my $abs_path = File::Spec->rel2abs( $path );
162 51         38 warn "Setting %INC entry of $module to $abs_path" if INTERNAL_DEBUG;
163 51         72 $INC{$module} = $abs_path;
164 51         1970 eval 'use $module_copy';
165 51         293 return $fh;
166             }
167              
168             sub _pm_search {
169              
170 52     52   55 my($pmfile) = @_;
171              
172 52         37 warn "Reviewing: $pmfile" if INTERNAL_DEBUG;
173 52         115 for(@INC) {
174             # Skip subrefs
175 510         294 warn "Next file: $_" if INTERNAL_DEBUG;
176 510 100       585 next if ref($_);
177 458         220 warn "Passed the ref test..." if INTERNAL_DEBUG;
178 458         2076 my $path = File::Spec->catfile($_, $pmfile);
179 458 100       3980 return $path if -f $path;
180             }
181              
182 1         3 return undef;
183             }
184              
185             sub _resurrector_fh {
186              
187 51     51   50 my( $file, ) = @_;
188 51         53 warn "Resurrecting lines from file: $file" if INTERNAL_DEBUG;
189 51         31 warn "with string: $strip_match" if INTERNAL_DEBUG;
190 51 50       1705 open my $start_file_handle, "<$file" or die "Cannot open $file";
191 51         52 my $text;
192             {
193             # read the file
194 51         48 local($/) = undef;
  51         206  
195 51         937 $text = <$start_file_handle>;
196 51         108 warn "Read ", length($text), " bytes from $file" if INTERNAL_DEBUG;
197             }
198 51         514 close $start_file_handle;
199              
200             # Transform the file
201 51         2227 $text =~ s/^(\s*)###$strip_match\s/$1/mg;
202 51         43 warn "----->script scrubbed file:\n$text" if VIEW_TRANSFORM;
203 51         33 warn "-------------------------------------------->Module Scrub complete" if INTERNAL_DEBUG;
204              
205             # Turn it back over to management by the INC loader via fh
206 51         312 my( $tmp_fh ) = File::Temp->new( UNLINK => 1, DIR => $temp_dir );# ( UNLINK => 1 );
207 51         15583 print $tmp_fh $text;
208 51         1251 seek $tmp_fh, 0, 0;
209              
210 51         192 return $tmp_fh;
211             }
212              
213             #########1 Phinish 3#########4#########5#########6#########7#########8#########9
214              
215             1;
216              
217             #########1 Documentation 3#########4#########5#########6#########7#########8#########9
218             __END__
219              
220             =head1 NAME
221              
222             Log::Shiras::Unhide - Unhides Log::Shiras hidden comments in @ISA
223              
224             =head1 SYNOPSIS
225              
226             #!perl
227             # Note this example uses the demonstration package Level1.pm Level2.pm, and Level3.pm
228             use lib '../lib',;
229              
230             BEGIN{
231             $ENV{hide_warn} = 1;
232             }
233             use Log::Shiras::Unhide qw( :debug :Meditation :Health :Family );
234             my $basic = 'Nothing';
235             ###LogSD $basic = 'Something';
236             warn 'Found ' . $basic;
237             my $health = 'Sick';
238             ###Health $health = 'Healthy';
239             warn 'I am ' . $health;
240             my $wealth = 'Broke';
241             ###Wealth $wealth = 'Rich';
242             warn 'I am ' . $wealth;
243             use Level1; # Which uses Level2 which uses Level3
244             warn Level1->check_return;
245              
246             #######################################################################################
247             # Synopsis Screen Output for the following conditions
248             # $ENV{hide_warn} = 1;# In a BEGIN block
249             # 'use Log::Shiras::Unhide qw( :debug :Meditation :Health :Family :InternalSwitchboarD );'
250             # 01: Using Log::Shiras::Unhide-v0.29_1 strip_match string: (LogSD|Meditation|Health|Family) at ../lib/Log/Shiras/Unhide.pm line 88.
251             # 02: Found Something at log_shiras_unhide.pl line 8.
252             # 03: I am Healthy at log_shiras_unhide.pl line 11.
253             # 04: I am Broke at log_shiras_unhide.pl line 14.
254             # 05: Level3 Peace uncovered - Level2 Healing uncovered - Level1 Joy uncovered at log_shiras_unhide.pl line 16.
255             #######################################################################################
256              
257             #######################################################################################
258             # Synopsis Screen Output for the following conditions
259             # $ENV{hide_warn} = 0;
260             # 'use Log::Shiras::Unhide( :debug );
261             # 01: Found Something at log_shiras_unhide.pl line 8.
262             # 02: I am Sick at log_shiras_unhide.pl line 11.
263             # 03: I am Broke at log_shiras_unhide.pl line 14.
264             # 04: Level3 LogSD uncovered - No Level2 uncovering occured - No Level1 uncovering occured at log_shiras_unhide.pl line 16.
265             #######################################################################################
266              
267             =head1 DESCRIPTION
268              
269             This package will strip '###SomeKey' tags from your script after the 'use Log::Shiras::Unhide;'
270             statement. It will also recursivly parse down through any included lower level modules as well.
271             If Log::Shiras::Unhide is called in some lower place it's import settings there will be
272             overridden by the top level call.
273              
274             Since this module implements a source filter and source filters are not universally loved the
275             module will generally emit a warning statement when it implements the source filter. To turn
276             that off you need to set $ENV{hide_warn} = 1 in a BEGIN block prior to 'use'ing
277             Log::Shiras::Unhide. The SYNOPSIS includes examples of various tags that are stripped at
278             compile time with some examples of tags in the code that are not stripped since they are
279             not passed to L<import|http://perldoc.perl.org/functions/import.html>. It is important to note
280             that both the synopsis and supporting modules are all stored in the 'examples' folder of this
281             distribution. You can inspect the specific implemenation for Level1.pm which uses Level2.pm
282             which uses Level3.pm. This demonstrates that the source filter is implemented accross the full
283             depth of used packages.
284              
285             When Moose uses a role with the word 'with' the Unhide process is not called. You can get
286             around this by calling 'use My::Role' prior to 'with My::Role'. The role will then be consumed
287             (implemented) by 'with' in it's stripped state.
288              
289             This class takes unashamedly from L<Log::Log4perl::Resurrector>. Any mistakes are my
290             own and the genius is from there. Log::Log4perl::Resurrector also credits the
291             L<Acme::Incorporated> CPAN module, written by L<chromatic|/https://metacpan.org/author/CHROMATIC>.
292             Of course none of it would be possible without L<Filter::Util::Call>. Long live CPAN!
293              
294             The point of using this module is to add lines that are only exposed some time. However,
295             this makes it difficult to troubleshoot syntax errors in those lines using your favorite
296             editor or debuger when implementing the lines to begin with. One way to resolve this is to
297             place two lines at the top of your code that will unhide those lines temporarily when you
298             are testing it and then either delelete or comment out the first line when releasing. The
299             purpose of the first line is to unhide your lines for testing and the second will issue a
300             warning so you don't forget you are in dev mode. An example is;
301              
302             #~ use Log::Shiras::Unhide qw( :MyCoolUnhideStrinG );
303             ###MyCoolUnhideStrinG warn "You uncovered internal logging statements for My::Cool::Package-$VERSION";
304              
305             If you choose to leave line two in then you also have an indication if the module was
306             implemented in a stripped fashion whenever you call it.
307              
308             TL;DR
309              
310             This package definitly falls in the dark magic catagory and will only slow your code down.
311             Don't use it if you arn't willing to pay the price. The value is all the interesting
312             information you receive from the exposed code. While this does use Filter::Util::Call
313             to handle scrubbing the top level script. The included modules are scrubbed with a L<hook
314             into @INC|http://perldoc.perl.org/functions/require.html> I<search for hook on that page>
315             The scrubbed modules are built and loaded via temporary files built with L<File::Temp>.
316             In general this is a good think since File::Temp does a good job of garbage collection
317             the garbage collection fails when the code 'dies' or 'confesses.. If your code regularly
318             dies or fails while ~::Unhide is active it will leave a lot of orphaned files in the temp
319             directory.
320              
321             This module also adds a startup hit to any processing where filtering is turned on and as
322             such should be used with caution, however, an attempt has been made to mitigate that by
323             excluding Module names matching the following regex;
324              
325             qr/(
326             ^Archive.Zip| ^attributes| ^AutoLoader| ^B\.pm|
327             ^B.(Op_|Deparse)| ^B.(Hooks)| ^Carp| ^Class|
328             ^Clone| ^common| ^Compress.Raw| ^Cwd|
329             ^Data.OptList| ^DateTime(?!X)| ^Devel| ^Encode|
330             ^Eval| ^Exporter| ^feature| ^File|
331             ^Filter| ^if\.pm| ^integer| ^IO.File|
332             ^JSON| ^List| ^Log.Shiras.Unhide| ^metaclass|
333             ^Module| ^Moose(?!X)| ^MooseX.Has| ^MooseX.Non|
334             ^MooseX.Singleton| ^MooseX.Strict| ^MooseX.Type| ^MRO|
335             ^namespace| ^Package| ^Params| ^parent|
336             ^PerlIO| ^POSIX| ^re\.pm| ^SelfLoader|
337             ^SetDual| ^Smart| ^Sub| ^Test2|
338             ^Tie| ^Text| ^Time.Local| ^Try|
339             ^Type| ^UNIVERSAL| ^utf8| ^Variable|
340             ^Win32| ^XML| ^YAML
341             )/x;
342              
343             =head2 Methods
344              
345             This module does not provide any methods for the user other than what is called during 'use'.
346             (import) Private methods will not be documented.
347              
348             =head3 import
349              
350             =over
351              
352             B<Definition:> perl auto calls import anytime the module is 'use'd. In this case the import
353             statement will accept (first only and optional) a minimum version requirement in either v-string or
354             decimal input. It will also accept any number of text strings matched to the regex [A-Za-z]+
355             prepended with ':'. These strings will be treated as case sensitive targets for this module
356             to find and expose the line behind them using a source filter. It will look in 'use'd modules
357             and strip those lines as well. The flags are transposed to include three '#'s without the colon.
358             There can be more than one passed flag and all will be implemented. An example of the stripping
359             implementation of imported flags are;
360              
361             qw(:FooBar :Baz) -> $line =~ s/^(\s*)###(FooBar|Baz)\s/$1/mg;
362              
363             There is one special flag that is transposed
364              
365             :debug -> strips '###LogSD' (for Log Shiras Debug)
366              
367             The overall package eats its own dogfood and uses module specific flags starting with 'InternaL'.
368             See the source for each module to understand which flag is used.
369              
370             B<Accepts:> $VERSION and colon prepended strip flags
371              
372             B<Returns:> nothing, but it transforms files prior to use
373              
374             =back
375              
376             =head1 Tags Available in CPAN
377              
378             This is a list (not comprehensive) of tags embedded in packages I have released to CPAN. Since
379             they require a source filter to uncover there should be minimal impact to using these packages
380             unless this class is used.
381              
382             =over
383              
384             B<:InternalSwitchboarD> - L<Log::Shiras::Switchboard>
385              
386             B<:InternalTelephonE> - L<Log::Shiras::Telephone>
387              
388             B<:InternalTypeSShirasFormat> - L<Log::Shiras::Types>
389              
390             B<:InternalTypeSFileHash> - L<Log::Shiras::Types>
391              
392             B<:InternalTypeSReportObject> - L<Log::Shiras::Types>
393              
394             B<:InternalLoGShiraSTesT> - L<Log::Shiras::Test2>
395              
396             B<:InternalTaPPrinT> - L<Log::Shiras::TapPrint>
397              
398             B<:InternalTaPWarN> - L<Log::Shiras::TapWarn>
399              
400             B<:InternalReporTCSV> - L<Log::Shiras::Report::CSVFile>
401              
402             B<:InternalBuilDInstancE> - L<MooseX::ShortCut::BuildInstance>
403              
404             B<:InternalExtracteD> - L<Data::Walk::Extracted>
405              
406             B<:InternalExtracteDGrafT> - L<Data::Walk::Graft>
407              
408             B<:InternalExtracteDClonE> - L<Data::Walk::Clone>
409              
410             B<:InternalExtracteDPrinT> - L<Data::Walk::Print>
411              
412             B<::InternalExtracteDPrunE> - L<Data::Walk::Prune>
413              
414             B<::InternalExtracteDDispatcH> - L<Data::Walk::Extracted::Dispatch>
415              
416             =back
417              
418             =head1 SUPPORT
419              
420             =over
421              
422             L<Log-Shiras/issues|https://github.com/jandrew/Log-Shiras/issues>
423              
424             =back
425              
426             =head1 GLOBAL VARIABLES
427              
428             =over
429              
430             =item B<$ENV{hide_warn}>
431              
432             The module will warn when tags are passed to it so you have visibility to Unhide
433             actions. In the case where the you don't want these notifications set this
434             environmental variable to true.
435              
436             =back
437              
438             =head1 TODO
439              
440             =over
441              
442             B<1.> Nothing L<currently|/SUPPORT>
443              
444             =back
445              
446             =head1 AUTHOR
447              
448             =over
449              
450             =item Jed Lund
451              
452             =item jandrew@cpan.org
453              
454             =back
455              
456             =head1 COPYRIGHT
457              
458             This program is free software; you can redistribute
459             it and/or modify it under the same terms as Perl itself.
460              
461             The full text of the license can be found in the
462             LICENSE file included with this module.
463              
464             This software is copyrighted (c) 2014 - 2016 by Jed Lund
465              
466             =head1 DEPENDENCIES
467              
468             =over
469              
470             L<perl 5.010|perl/5.10.0>
471              
472             L<version>
473              
474             L<File::Temp>
475              
476             L<File::Spec>
477              
478             L<Data::Dumper>
479              
480             L<Filter::Util::Call>
481              
482             =back
483              
484             =head1 SEE ALSO
485              
486             =over
487              
488             L<Log::Log4perl::Resurrector>
489              
490             L<Filter::Util::Call>
491              
492             =back
493              
494             =cut
495              
496             #########1#########2 main pod documentation end 5#########6#########7#########8#########9