File Coverage

lib/Class/Usul/TraitFor/DebugFlag.pm
Criterion Covered Total %
statement 21 24 87.5
branch 4 4 100.0
condition n/a
subroutine 8 9 88.8
pod 2 2 100.0
total 35 39 89.7


line stmt bran cond sub pod time code
1             package Class::Usul::TraitFor::DebugFlag;
2              
3 18     18   15191 use namespace::autoclean;
  18         68  
  18         179  
4              
5 18     18   2014 use Class::Usul::Constants qw( FALSE TRUE );
  18         69  
  18         209  
6 18     18   16520 use Class::Usul::Functions qw( ns_environment );
  18         54  
  18         159  
7 18     18   25088 use Class::Usul::Types qw( Bool );
  18         69  
  18         220  
8 18     18   18961 use Moo::Role;
  18         56  
  18         226  
9 18     18   9493 use Class::Usul::Options;
  18         66  
  18         185  
10              
11             requires qw( config is_interactive yorn );
12              
13             # Attribute constructors
14             my $_build_debug = sub {
15 6 100   6   50360 return !!ns_environment( $_[ 0 ]->config->appclass, 'debug' ) ? TRUE : FALSE;
16             };
17              
18             # Public attributes
19             option 'debug' => is => 'rwp', isa => Bool, builder => $_build_debug,
20             documentation => 'Turn debugging on. Prompts if interactive',
21             short => 'D', lazy => TRUE;
22              
23             option 'noask' => is => 'ro', isa => Bool, default => FALSE,
24             documentation => 'Do not prompt for debugging', short => 'n';
25              
26             # Private methods
27             my $_dont_ask = sub {
28             my $self = shift; return $self->debug || !$self->is_interactive();
29             };
30              
31             my $_get_debug_option = sub {
32             my $self = shift;
33              
34             ($self->noask or $self->$_dont_ask) and return $self->debug;
35              
36             return $self->yorn( 'Do you want debugging turned on', FALSE, TRUE );
37             };
38              
39             # Construction
40             around 'BUILDARGS' => sub {
41             my ($orig, $self, @args) = @_; my $attr = $orig->( $self, @args );
42              
43             my $deprecated = delete $attr->{nodebug}; $attr->{noask} //= $deprecated;
44              
45             return $attr;
46             };
47              
48             sub BUILD { # Must not call logger before this executes
49 0     0 1 0 my $self = shift; $self->_set_debug( $self->$_get_debug_option ); return;
  0         0  
  0         0  
50             }
51              
52             # Public methods
53             sub debug_flag {
54 2 100   2 1 7218 my $self = shift; return $self->debug ? '-D' : '-n';
  2         58  
55             }
56              
57             1;
58              
59             __END__
60              
61             =pod
62              
63             =encoding utf-8
64              
65             =head1 Name
66              
67             Class::Usul::TraitFor::DebugFlag - Handles the state of the debug flag
68              
69             =head1 Synopsis
70              
71             use Moo;
72              
73             extends 'Class::Usul';
74             with 'Class::Usul::TraitFor::DebugFlag';
75              
76             =head1 Description
77              
78             Handles the state of the debug flag
79              
80             =head1 Configuration and Environment
81              
82             Defines the following command line options;
83              
84             =over 3
85              
86             =item C<D debug>
87              
88             Turn debugging on
89              
90             =item C<n noask>
91              
92             Do not prompt to turn debugging on
93              
94             =back
95              
96             =head1 Subroutines/Methods
97              
98             =head2 BUILD
99              
100             Called just after the object is constructed this method handles prompting for
101             the debug state if it is an interactive session. Also offers the option to quit
102              
103             =head2 debug_flag
104              
105             $cmd_line_option = $self->debug_flag
106              
107             Returns the command line debug flag to match the current debug state
108              
109             =head1 Diagnostics
110              
111             None
112              
113             =head1 Dependencies
114              
115             =over 3
116              
117             =item L<Class::Usul::Options>
118              
119             =item L<Moo::Role>
120              
121             =back
122              
123             =head1 Incompatibilities
124              
125             There are no known incompatibilities in this module
126              
127             =head1 Bugs and Limitations
128              
129             There are no known bugs in this module. Please report problems to
130             http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Usul.
131             Patches are welcome
132              
133             =head1 Acknowledgements
134              
135             Larry Wall - For the Perl programming language
136              
137             =head1 Author
138              
139             Peter Flanigan, C<< <pjfl@cpan.org> >>
140              
141             =head1 License and Copyright
142              
143             Copyright (c) 2017 Peter Flanigan. All rights reserved
144              
145             This program is free software; you can redistribute it and/or modify it
146             under the same terms as Perl itself. See L<perlartistic>
147              
148             This program is distributed in the hope that it will be useful,
149             but WITHOUT WARRANTY; without even the implied warranty of
150             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
151              
152             =cut
153              
154             # Local Variables:
155             # mode: perl
156             # tab-width: 3
157             # End:
158             # vim: expandtab shiftwidth=3: