Login
Self-compliance with ProhibitUnrestrictedNoCritic
[gknop/Perl-Critic.git] / t / 07_perlcritic.t
1 #!perl
2
3 ##############################################################################
4 #     $URL$
5 #    $Date$
6 #   $Author$
7 # $Revision$
8 ##############################################################################
9
10 use 5.006001;
11 use strict;
12 use warnings;
13
14 use English qw(-no_match_vars);
15 use Carp qw< confess >;
16
17 use File::Spec;
18
19 use Perl::Critic::Utils qw< :characters >;
20
21 use Test::More tests => 37;
22
23 #-----------------------------------------------------------------------------
24
25 our $VERSION = '1.093_01';
26
27 #-----------------------------------------------------------------------------
28
29 # Load perlcritic like a library so we can test its subroutines.  If it is not
30 # found in blib, then use the one in bin (for example, when using 'prove')
31
32 my $perlcritic = File::Spec->catfile( qw(blib script perlcritic) );
33 if (not -e $perlcritic) {
34     $perlcritic = File::Spec->catfile( qw(bin perlcritic) )
35 }
36 require $perlcritic;  ## no critic (StringyEval)
37
38 # Because bin/perlcritic does not declare a package, it has functions
39 # in main, just like this test file, so we can use its functions
40 # without a prefix.
41
42 #-----------------------------------------------------------------------------
43
44 local @ARGV = ();
45 my $message;
46 my %options = ();
47
48 #-----------------------------------------------------------------------------
49
50 local @ARGV = qw(-1 -2 -3 -4 -5);
51 $message = "@ARGV";
52 %options = get_options();
53 is( $options{-severity}, 1, $message);
54
55 local @ARGV = qw(-5 -3 -4 -1 -2);
56 $message = "@ARGV";
57 %options = get_options();
58 is( $options{-severity}, 1, $message);
59
60 local @ARGV = qw();
61 %options = get_options();
62 is( $options{-severity}, undef, 'no arguments');
63
64 local @ARGV = qw(-2 -3 -severity 4);
65 $message = "@ARGV";
66 %options = get_options();
67 is( $options{-severity}, 4, $message);
68
69 local @ARGV = qw(-severity 2 -3 -4);
70 $message = "@ARGV";
71 %options = get_options();
72 is( $options{-severity}, 2, $message);
73
74 local @ARGV = qw(--severity=2 -3 -4);
75 $message = "@ARGV";
76 %options = get_options();
77 is( $options{-severity}, 2, $message);
78
79 local @ARGV = qw(-cruel);
80 $message = "@ARGV";
81 %options = get_options();
82 is( $options{-severity}, 'cruel', $message);
83
84 local @ARGV = qw(-cruel --severity=1 );
85 $message = "@ARGV";
86 %options = get_options();
87 is( $options{-severity}, 1, $message);
88
89 local @ARGV = qw(-stern --severity=1 -2);
90 $message = "@ARGV";
91 %options = get_options();
92 is( $options{-severity}, 1, $message);
93
94 local @ARGV = qw(-stern -severity 1 -2);
95 $message = "@ARGV";
96 %options = get_options();
97 is( $options{-severity}, 1, $message);
98
99 #-----------------------------------------------------------------------------
100
101 local @ARGV = qw(-top);
102 $message = "@ARGV";
103 %options = get_options();
104 is( $options{-severity}, 1, $message);
105 is( $options{-top}, 20, $message);
106
107 local @ARGV = qw(-top 10);
108 $message = "@ARGV";
109 %options = get_options();
110 is( $options{-severity}, 1, $message);
111 is( $options{-top}, 10, $message);
112
113 local @ARGV = qw(-severity 4 -top);
114 $message = "@ARGV";
115 %options = get_options();
116 is( $options{-severity}, 4, $message);
117 is( $options{-top}, 20, $message);
118
119 local @ARGV = qw(-severity 4 -top 10);
120 $message = "@ARGV";
121 %options = get_options();
122 is( $options{-severity}, 4, $message);
123 is( $options{-top}, 10, $message);
124
125 local @ARGV = qw(-severity 5 -2 -top 5);
126 $message = "@ARGV";
127 %options = get_options();
128 is( $options{-severity}, 5, $message);
129 is( $options{-top}, 5, $message);
130
131 #-----------------------------------------------------------------------------
132
133 local @ARGV = qw(-noprofile);
134 $message = "@ARGV";
135 %options = get_options();
136 is( $options{-profile}, q{}, $message);
137
138 local @ARGV = qw(-profile foo);
139 $message = "@ARGV";
140 %options = get_options();
141 is( $options{-profile}, 'foo', $message);
142
143 #-----------------------------------------------------------------------------
144
145 local @ARGV = qw(-single-policy nowarnings);
146 $message = "@ARGV";
147 %options = get_options();
148 is( $options{'-single-policy'}, 'nowarnings', $message);
149
150 #-----------------------------------------------------------------------------
151
152 local @ARGV = qw(-verbose 2);
153 $message = "@ARGV";
154 %options = get_options();
155 is( $options{-verbose}, 2, $message);
156
157 local @ARGV = qw(-verbose %l:%c:%m);
158 %options = get_options();
159 is( $options{-verbose}, '%l:%c:%m', $message);
160
161 #-----------------------------------------------------------------------------
162
163 local @ARGV = qw(-statistics);
164 $message = "@ARGV";
165 %options = get_options();
166 is( $options{-statistics}, 1, $message);
167
168 #-----------------------------------------------------------------------------
169
170 local @ARGV = qw(-statistics-only);
171 $message = "@ARGV";
172 %options = get_options();
173 is( $options{'-statistics-only'}, 1, $message);
174
175 #-----------------------------------------------------------------------------
176
177 local @ARGV = qw(-quiet);
178 $message = "@ARGV";
179 %options = get_options();
180 is( $options{-quiet}, 1, $message);
181
182
183 #-----------------------------------------------------------------------------
184
185 local @ARGV = qw(-pager foo);
186 %options = eval { get_options() };
187 is( $options{-pager}, 'foo',  "@ARGV" );
188
189
190 #-----------------------------------------------------------------------------
191 # Intercept pod2usage so we can test invalid options and special switches
192
193 {
194     no warnings qw(redefine once); ## no critic (ProhibitNoWarnings)
195     local *main::pod2usage = sub { my %args = @_; confess $args{-message} || q{} };
196
197     local @ARGV = qw( -help );
198     eval { get_options() };
199     ok( $EVAL_ERROR, '-help option' );
200
201     local @ARGV = qw( -options );
202     eval { get_options() };
203     ok( $EVAL_ERROR, '-options option' );
204
205     local @ARGV = qw( -man );
206     eval { get_options() };
207     ok( $EVAL_ERROR, '-man option' );
208
209     local @ARGV = qw( -noprofile -profile foo );
210     eval { get_options() };
211     like(
212         $EVAL_ERROR,
213         qr/-noprofile [ ] with [ ] -profile/xms,
214         '-noprofile with -profile',
215     );
216
217     local @ARGV = qw( -verbose bogus );
218     eval { get_options() };
219     like(
220         $EVAL_ERROR,
221         qr/looks [ ] odd/xms,
222         'Invalid -verbose option',
223     );
224
225     local @ARGV = qw( -top -9 );
226     eval { get_options() };
227     like(
228         $EVAL_ERROR,
229         qr/is [ ] negative/xms,
230         'Negative -verbose option',
231     );
232
233     local @ARGV = qw( -severity 0 );
234     eval { get_options() };
235     like(
236         $EVAL_ERROR,
237         qr/out [ ] of [ ] range/xms,
238         '-severity too small',
239     );
240
241     local @ARGV = qw( -severity 6 );
242     eval { get_options() };
243     like(
244         $EVAL_ERROR,
245         qr/out [ ] of [ ] range/xms,
246         '-severity too large',
247     );
248 }
249
250 #-----------------------------------------------------------------------------
251
252 # ensure we run true if this test is loaded by
253 # t/07_perlcritic.t_without_optional_dependencies.t
254 1;
255
256 # Local Variables:
257 #   mode: cperl
258 #   cperl-indent-level: 4
259 #   fill-column: 78
260 #   indent-tabs-mode: nil
261 #   c-indentation-style: bsd
262 # End:
263 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :