File Coverage

blib/lib/Perl/Critic/Policy/Compatibility/Gtk2Constants.pm
Criterion Covered Total %
statement 95 102 93.1
branch 38 50 76.0
condition 20 22 90.9
subroutine 18 19 94.7
pod 1 1 100.0
total 172 194 88.6


line stmt bran cond sub pod time code
1             # Copyright 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2019 Kevin Ryde
2              
3             # Perl-Critic-Pulp is free software; you can redistribute it and/or modify
4             # it under the terms of the GNU General Public License as published by the
5             # Free Software Foundation; either version 3, or (at your option) any later
6             # version.
7             #
8             # Perl-Critic-Pulp is distributed in the hope that it will be useful, but
9             # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
10             # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
11             # for more details.
12             #
13             # You should have received a copy of the GNU General Public License along
14             # with Perl-Critic-Pulp. If not, see <http://www.gnu.org/licenses/>.
15              
16              
17             package Perl::Critic::Policy::Compatibility::Gtk2Constants;
18 40     40   31996 use 5.006;
  40         160  
19 40     40   276 use strict;
  40         83  
  40         869  
20 40     40   203 use warnings;
  40         104  
  40         1145  
21 40     40   214 use List::Util;
  40         96  
  40         1956  
22 40     40   625 use version (); # but don't import qv()
  40         1610  
  40         900  
23 40     40   231 use base 'Perl::Critic::Policy';
  40         101  
  40         5211  
24 40         2334 use Perl::Critic::Utils qw(is_function_call
25 40     40   147420 is_method_call);
  40         84  
26 40     40   795 use Perl::Critic::Pulp::Utils;
  40         115  
  40         2423  
27              
28             # uncomment this to run the ### lines
29             #use Smart::Comments;
30              
31             our $VERSION = 98;
32              
33 40     40   268 use constant supported_parameters => ();
  40         106  
  40         2682  
34 40     40   281 use constant default_severity => $Perl::Critic::Utils::SEVERITY_MEDIUM;
  40         153  
  40         2474  
35 40     40   272 use constant default_themes => qw(pulp bugs);
  40         112  
  40         2402  
36 40     40   255 use constant applies_to => qw(PPI::Token::Word PPI::Token::Symbol);
  40         93  
  40         43232  
37              
38             my $v1_190 = version->new('1.190');
39             my $v1_210 = version->new('1.210');
40             my $v1_211 = version->new('1.211');
41              
42             my %constants = (
43             GTK_PRIORITY_RESIZE => ['Gtk2',$v1_190],
44             GDK_PRIORITY_EVENTS => ['Gtk2',$v1_190],
45             GDK_PRIORITY_REDRAW => ['Gtk2',$v1_190],
46             GDK_CURRENT_TIME => ['Gtk2',$v1_190],
47              
48             EVENT_PROPAGATE => ['Gtk2',$v1_210],
49             EVENT_STOP => ['Gtk2',$v1_210],
50              
51             GTK_PATH_PRIO_LOWEST => ['Gtk2',$v1_211],
52             GTK_PATH_PRIO_GTK => ['Gtk2',$v1_211],
53             GTK_PATH_PRIO_APPLICATION => ['Gtk2',$v1_211],
54             GTK_PATH_PRIO_THEME => ['Gtk2',$v1_211],
55             GTK_PATH_PRIO_RC => ['Gtk2',$v1_211],
56             GTK_PATH_PRIO_HIGHEST => ['Gtk2',$v1_211],
57              
58             SOURCE_CONTINUE => ['Glib',$v1_210],
59             SOURCE_REMOVE => ['Glib',$v1_210],
60             );
61              
62             sub violates {
63 79     79 1 558598 my ($self, $elem, $document) = @_;
64              
65 79         127 my $elem_str;
66 79 100       327 if ($elem->isa('PPI::Token::Symbol')) {
67 16 100       61 $elem->symbol_type eq '&'
68             or return; # only &SOURCE_REMOVE is for us
69 10         296 $elem_str = substr $elem->symbol, 1;
70             } else {
71 63         159 $elem_str = $elem->content;
72             }
73 73         417 my ($elem_qualifier, $elem_basename) = _qualifier_and_basename ($elem_str);
74              
75             # quick lookup excludes names not of interest
76 73   100     338 my $constinfo = $constants{$elem_basename}
77             || return;
78 32         103 my ($const_module, $want_version) = @$constinfo;
79              
80 32 100 100     223 if ($elem->isa('PPI::Token::Symbol') || is_function_call ($elem)) {
    100          
81 24 100       4012 if (defined $elem_qualifier) {
82 18 100       93 if ($elem_qualifier ne $const_module) {
83 1         6 return; # from another module, eg. Foo::Bar::SOURCE_REMOVE
84             }
85             } else {
86 6 100       21 if (! _document_uses_module ($document, $const_module)) {
87 4         59 return; # unqualified SOURCE_REMOVE, and no mention of Glib, etc
88             }
89             }
90              
91             } elsif (is_method_call ($elem)) {
92 6 50       1183 if (defined $elem_qualifier) {
93             # an oddity like Some::Where->Gtk2::SOURCE_REMOVE
94 0 0       0 if ($elem_qualifier ne $const_module) {
95 0         0 return; # from another module, Some::Where->Foo::Bar::SOURCE_REMOVE
96             }
97             } else {
98             # unqualified method name, eg. Some::Thing->SOURCE_REMOVE
99 6         18 my $class_elem = $elem->sprevious_sibling->sprevious_sibling;
100 6 100 100     205 if (! $class_elem || ! $class_elem->isa('PPI::Token::Word')) {
101             # ignore oddities like $foo->SOURCE_REMOVE
102 2         7 return;
103             }
104 4         12 my $class_name = $class_elem->content;
105 4 100       25 if ($class_name ne $const_module) {
106             # some other class, eg. Foo::Bar->SOURCE_REMOVE
107 1         4 return;
108             }
109             }
110              
111             } else {
112             # not a function or method call
113 2         632 return;
114             }
115              
116 22         195 my $got_version = _highest_explicit_module_version ($document,$const_module);
117 22 100 100     174 if (defined $got_version && ref $got_version) {
118 14 100       114 if ($got_version >= $want_version) {
119 9         34 return;
120             }
121             }
122              
123 13 100 100     54 return $self->violation
124             ("$elem requires $const_module $want_version, but "
125             . (defined $got_version && ref $got_version
126             ? "version in file is $got_version"
127             : "no version specified in file"),
128             '',
129             $elem);
130             }
131              
132             # "Foo" return (undef, "Foo")
133             # "Foo::Bar::Quux" return ("Foo::Bar", "Quux")
134             #
135             sub _qualifier_and_basename {
136 77     77   4219 my ($str) = @_;
137 77         412 return ($str =~ /(?:(.*)::)?(.*)/);
138             }
139              
140             # return true if $document has a "use" or "require" of $module (string name
141             # of a package)
142             sub _document_uses_module {
143 6     6   20 my ($document, $module) = @_;
144              
145 6   100     22 my $aref = $document->find ('PPI::Statement::Include')
146             || return; # if no Includes at all
147 2 50 50 2   12 return List::Util::first {$_->type eq 'use'
148             && (($_->module || '') eq $module)
149 2         32 } @$aref;
150             }
151              
152             # return a "version" object which is the highest explicit use for $module (a
153             # string) in $document
154             #
155             # A call like Foo::Bar->VERSION(123) is a version check, but not sure that's
156             # worth looking for.
157             #
158             # If there's no version number on any "use" of $module then the return is
159             # version->new(0). If there's no "use" of $module at all then the return is
160             # undef.
161             #
162             sub _highest_explicit_module_version {
163 22     22   68 my ($document, $module) = @_;
164              
165 22         64 my $cache_key = __PACKAGE__.'::_highest_explicit_module_version--'.$module;
166 22 50       86 if (exists $document->{$cache_key}) { return $document->{$cache_key}; }
  0         0  
167              
168 22   100     92 my $aref = $document->find ('PPI::Statement::Include')
169             || return; # if no Includes at all
170 16 50 50     255 my @incs = grep {$_->type eq 'use'
  16         79  
171             && (($_->module || '') eq $module)} @$aref;
172             ### all incs: @$aref
173             ### matched incs: @incs
174 16 50       815 if (! @incs) { return undef; }
  0         0  
175              
176 16         42 my @vers = map { _include_module_version_with_exporter($_) } @incs;
  16         61  
177             ### versions: @vers
178 16         155 @vers = grep {defined} @vers;
  16         60  
179 16 100       68 if (! @vers) { return 0; }
  2         7  
180              
181 14         33 @vers = map {version->new($_)} @vers;
  14         120  
182 14 0   0   139 my $maxver = List::Util::reduce {$a >= $b ? $a : $b} @vers;
  0         0  
183 14         105 return ($document->{$cache_key} = $maxver);
184             }
185              
186              
187             # $inc is a PPI::Statement::Include.
188             #
189             # If $inc has a version number, either in perl's native form or as a string
190             # or number as handled by the Exporter package, then return that as a
191             # version object.
192             #
193             sub _include_module_version_with_exporter {
194 16     16   42 my ($inc) = @_;
195              
196 16 100       87 if (my $ver = Perl::Critic::Pulp::Utils::include_module_version ($inc)) {
197 8         25 return version->new ($ver->content);
198             }
199              
200 8 100       27 if (my $ver = Perl::Critic::Pulp::Utils::include_module_first_arg ($inc)) {
201 6 50       46 if ($ver->isa('PPI::Token::Number')) {
    50          
202 0         0 $ver = $ver->content;
203             } elsif ($ver->isa('PPI::Token::Quote')) {
204 6         35 $ver = $ver->string;
205             } else {
206 0         0 return undef;
207             }
208             # Exporter looks only for a leading digit before calling ->VERSION, but
209             # be tighter here to avoid errors from version.pm about bad values
210 6 50       160 if ($ver =~ $Perl::Critic::Pulp::Utils::use_module_version_number_re) {
211 6         99 return version->new ($ver);
212             }
213             }
214              
215 2         9 return undef;
216             }
217              
218             1;
219             __END__
220              
221             =for stopwords Gtk2 Ryde
222              
223             =head1 NAME
224              
225             Perl::Critic::Policy::Compatibility::Gtk2Constants - new enough Gtk2 version for its constants
226              
227             =head1 DESCRIPTION
228              
229             This policy is part of the L<C<Perl::Critic::Pulp>|Perl::Critic::Pulp>
230             add-on. It requires that if you use certain constant subs from
231             L<C<Gtk2>|Gtk2> and L<C<Glib>|Glib> then you must explicitly have a C<use>
232             of a high enough version of those modules.
233              
234             use Gtk2 1.160;
235             ... return Gtk2::EVENT_PROPAGATE; # bad
236              
237             use Gtk2 1.200 ':constants';
238             ... return GDK_CURRENT_TIME; # good
239              
240             The following C<Gtk2> constants are checked,
241              
242             GTK_PRIORITY_RESIZE # new in Gtk2 1.200 (devel 1.190)
243             GDK_PRIORITY_EVENTS
244             GDK_PRIORITY_REDRAW
245             GDK_CURRENT_TIME
246              
247             EVENT_PROPAGATE # new in Gtk2 1.220 (devel 1.210)
248             EVENT_STOP
249              
250             GTK_PATH_PRIO_LOWEST # new in Gtk2 1.220 (devel 1.211)
251             GTK_PATH_PRIO_GTK
252             GTK_PATH_PRIO_APPLICATION
253             GTK_PATH_PRIO_THEME
254             GTK_PATH_PRIO_RC
255             GTK_PATH_PRIO_HIGHEST
256              
257             and the following C<Glib> constants
258              
259             SOURCE_CONTINUE # new in Glib 1.220 (devel 1.210)
260             SOURCE_REMOVE
261              
262             The idea is to keep you from using the constants without a new enough
263             C<Gtk2> or C<Glib>. Of course there's a huge number of other things you
264             might do that also require a new enough version, but these constants tripped
265             me up a few times.
266              
267             The exact version numbers above and demanded are development versions.
268             You're probably best off rounding up to a "stable" one like 1.200 or 1.220.
269              
270             As always if you don't care about this and in particular if for instance you
271             only ever use Gtk2 1.220 or higher anyway then you can disable
272             C<Gtk2Constants> from your F<.perlcriticrc> in the usual way (see
273             L<Perl::Critic/CONFIGURATION>),
274              
275             [-Compatibility::Gtk2Constants]
276              
277             =head2 Constant Forms
278              
279             Constants are recognised as any of for instance
280              
281             EVENT_PROPAGATE
282             Gtk2::EVENT_PROPAGATE
283             Gtk2->EVENT_PROPAGATE
284             &EVENT_PROPAGATE
285             &Gtk2::EVENT_PROPAGATE
286              
287             When there's a class name given it's checked, so that other uses of say
288             C<EVENT_PROPAGATE> aren't picked up.
289              
290             Some::Other::Thing::EVENT_PROPAGATE # ok
291             Some::Other::Thing->EVENT_PROPAGATE # ok
292             &Some::Other::Thing::EVENT_PROPAGATE # ok
293              
294             When there's no class name, then it's only assumed to be Gtk2 or Glib when
295             the respective module has been included.
296              
297             use Something::Else;
298             EVENT_PROPAGATE # ok
299              
300             use Gtk2 ':constants';
301             EVENT_PROPAGATE # bad
302              
303             In the latter form there's no check for C<:constants> or explicit import in
304             the C<use>, it's assumed that if you've used Gtk2 then C<EVENT_PROPAGATE>
305             means that one no matter how the imports might be arranged.
306              
307             =head1 SEE ALSO
308              
309             L<Perl::Critic::Pulp>, L<Perl::Critic>, L<Gtk2>, L<Glib>
310              
311             =head1 HOME PAGE
312              
313             L<http://user42.tuxfamily.org/perl-critic-pulp/index.html>
314              
315             =head1 COPYRIGHT
316              
317             Copyright 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2019 Kevin Ryde
318              
319             Perl-Critic-Pulp is free software; you can redistribute it and/or modify it
320             under the terms of the GNU General Public License as published by the Free
321             Software Foundation; either version 3, or (at your option) any later
322             version.
323              
324             Perl-Critic-Pulp is distributed in the hope that it will be useful, but
325             WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
326             or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
327             more details.
328              
329             You should have received a copy of the GNU General Public License along with
330             Perl-Critic-Pulp. If not, see <http://www.gnu.org/licenses/>.
331              
332             =cut