git.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm $
   3 #     $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
   4 #   $Author: clonezone $
   5 # $Revision: 2489 $
   6 ##############################################################################
   7
   8 package Perl::Critic::Policy::ErrorHandling::RequireCarping;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13 use Readonly;
  14
  15 use Perl::Critic::Utils qw{
  16     :booleans :characters :severities :classification :data_conversion
  17 };
  18 use Perl::Critic::Utils::PPI qw{ is_ppi_expression_or_generic_statement };
  19 use base 'Perl::Critic::Policy';
  20
  21 our $VERSION = '1.088';
  22
  23 #-----------------------------------------------------------------------------
  24
  25 Readonly::Scalar my $EXPL => [ 283 ];
  26
  27 #-----------------------------------------------------------------------------
  28
  29 sub supported_parameters {
  30     return (
  31         {
  32             name           => 'allow_messages_ending_with_newlines',
  33             description    => q{Don't complain about die or warn if the message ends in a newline.},
  34             default_string => '1',
  35             behavior       => 'boolean',
  36         },
  37     );
  38 }
  39
  40 sub default_severity  { return $SEVERITY_MEDIUM                          }
  41 sub default_themes    { return qw( core pbp maintenance )                }
  42 sub applies_to        { return 'PPI::Token::Word'                        }
  43
  44 #-----------------------------------------------------------------------------
  45
  46 sub violates {
  47     my ( $self, $elem, undef ) = @_;
  48
  49     my $alternative;
  50     if ( $elem eq 'warn' ) {
  51         $alternative = 'carp';
  52     }
  53     elsif ( $elem eq 'die' ) {
  54         $alternative = 'croak';
  55     }
  56     else {
  57         return;
  58     }
  59
  60     return if ! is_function_call($elem);
  61
  62     if ($self->{_allow_messages_ending_with_newlines}) {
  63         return if _last_flattened_argument_list_element_ends_in_newline($elem);
  64     }
  65
  66     my $desc = qq{"$elem" used instead of "$alternative"};
  67     return $self->violation( $desc, $EXPL, $elem );
  68 }
  69
  70 #-----------------------------------------------------------------------------
  71
  72 sub _last_flattened_argument_list_element_ends_in_newline {
  73     my $die_or_warn = shift;
  74
  75     my $last_flattened_argument =
  76         _find_last_flattened_argument_list_element($die_or_warn);
  77     if (
  78             $last_flattened_argument
  79         and (
  80                 $last_flattened_argument->isa('PPI::Token::Quote::Double')
  81             or  $last_flattened_argument->isa('PPI::Token::Quote::Interpolate')
  82         )
  83     ) {
  84         return $TRUE if $last_flattened_argument =~ m{ [\\] n . \z }xmso;
  85     }
  86
  87     return $FALSE
  88 }
  89
  90 #-----------------------------------------------------------------------------
  91 # Here starts the fun.  Explanation by example:
  92 #
  93 # Let's say we've got the following (contrived) statement:
  94 #
  95 #    die q{Isn't }, ( $this, ( " fun?\n" ) , ) if "It isn't Monday.";
  96 #
  97 # This statement should pass because the last parameter that die is going to
  98 # get is C<" fun?\n">.
  99 #
 100 # The approach is to first find the last non-flattened parameter.  If this
 101 # is a simple token, we're done.  Else, it's some aggregate thing.  We can't
 102 # tell what C<some_function( "foo\n" )> is going to do, so we give up on
 103 # anything other than a PPI::Structure::List.
 104 #
 105 # There are three possible scenarios for the children of a List:
 106 #
 107 #   * No children of the List, i.e. the list looks like C< ( ) >.
 108 #   * One PPI::Statement::Expression element.
 109 #   * One PPI::Statement element.  That's right, an instance of the base
 110 #     statement class and not some subclass.  *sigh*
 111 #
 112 # In the first case, we're done.  The latter two cases get treated
 113 # identically.  We get the last child of the Statement and start the search
 114 # all over again.
 115 #
 116 # Back to our example.  The PPI tree for this expression is
 117 #
 118 #     PPI::Document
 119 #       PPI::Statement
 120 #         PPI::Token::Word    'die'
 121 #         PPI::Token::Quote::Literal          'q{Isn't }'
 122 #         PPI::Token::Operator        ','
 123 #         PPI::Structure::List        ( ... )
 124 #           PPI::Statement::Expression
 125 #             PPI::Token::Symbol      '$this'
 126 #             PPI::Token::Operator    ','
 127 #             PPI::Structure::List    ( ... )
 128 #               PPI::Statement::Expression
 129 #                 PPI::Token::Quote::Double   '" fun?\n"'
 130 #             PPI::Token::Operator    ','
 131 #         PPI::Token::Word    'if'
 132 #         PPI::Token::Quote::Double   '"It isn't Monday.\n"'
 133 #         PPI::Token::Structure       ';'
 134 #
 135 # We're starting with the Word containing 'die' (it could just as well be
 136 # 'warn') because the earlier parts of validate() have taken care of any
 137 # other possibility.  We're going to scan forward through 'die's siblings
 138 # until we reach what we think the end of its parameters are. So we get
 139 #
 140 #     1. A Literal. A perfectly good argument.
 141 #     2. A comma operator. Looks like we've got more to go.
 142 #     3. A List. Another argument.
 143 #     4. The Word 'if'.  Oops.  That's a postfix operator.
 144 #
 145 # Thus, the last parameter is the List.  So, we've got to scan backwards
 146 # through the components of the List; again, the goal is to find the last
 147 # value in the flattened list.
 148 #
 149 # Before decending into the List, we check that it isn't a subroutine call by
 150 # looking at its prior sibling.  In this case, the prior sibling is a comma
 151 # operator, so it's fine.
 152 #
 153 # The List has one Expression element as we expect.  We grab the Expression's
 154 # last child and start all over again.
 155 #
 156 #     1. The last child is a comma operator, which Perl will ignore, so we
 157 #        skip it.
 158 #     2. The comma's prior sibling is a List.  This is the last significant
 159 #        part of the outer list.
 160 #     3. The List's prior sibling isn't a Word, so we can continue because the
 161 #        List is not a parameter list.
 162 #     4. We go through the child Expression and find that the last child of
 163 #        that is a PPI::Token::Quote::Double, which is a simple, non-compound
 164 #        token.  We return that and we're done.
 165
 166 sub _find_last_flattened_argument_list_element {
 167     my $die_or_warn = shift;
 168
 169     # Zoom forward...
 170     my $current_candidate =
 171         _find_last_element_in_subexpression($die_or_warn);
 172
 173     # ... scan back.
 174     while (
 175             $current_candidate
 176         and not _is_simple_list_element_token( $current_candidate )
 177         and not _is_complex_expression_token( $current_candidate )
 178     ) {
 179         if ( $current_candidate->isa('PPI::Structure::List') ) {
 180             $current_candidate =
 181                 _determine_if_list_is_a_plain_list_and_get_last_child(
 182                     $current_candidate,
 183                     $die_or_warn
 184                 );
 185         } elsif ( not $current_candidate->isa('PPI::Token') ) {
 186             return;
 187         } else {
 188             $current_candidate = $current_candidate->sprevious_sibling();
 189         }
 190     }
 191
 192     return if not $current_candidate;
 193     return if _is_complex_expression_token( $current_candidate );
 194
 195     my $penultimate_element = $current_candidate->sprevious_sibling();
 196     if ($penultimate_element) {
 197         # Bail if we've got a Word in front of the Element that isn't
 198         # the original 'die' or 'warn' or anything else that isn't
 199         # a comma or dot operator.
 200         if ( $penultimate_element->isa('PPI::Token::Operator') ) {
 201             if (
 202                     $penultimate_element ne $COMMA
 203                 and $penultimate_element ne $PERIOD
 204             ) {
 205                 return;
 206             }
 207         } elsif ( $penultimate_element != $die_or_warn ) {
 208             return
 209         }
 210     }
 211
 212     return $current_candidate;
 213 }
 214
 215 #-----------------------------------------------------------------------------
 216 # This is the part where we scan forward from the 'die' or 'warn' to find
 217 # the last argument.
 218
 219 sub _find_last_element_in_subexpression {
 220     my $die_or_warn = shift;
 221
 222     my $last_following_sibling;
 223     my $next_sibling = $die_or_warn;
 224     while (
 225             $next_sibling = $next_sibling->snext_sibling()
 226         and not _is_postfix_operator( $next_sibling )
 227     ) {
 228         $last_following_sibling = $next_sibling;
 229     }
 230
 231     return $last_following_sibling;
 232 }
 233
 234 #-----------------------------------------------------------------------------
 235 # Ensure that the list isn't a parameter list.  Find the last element of it.
 236
 237 sub _determine_if_list_is_a_plain_list_and_get_last_child {
 238     my ($list, $die_or_warn) = @_;
 239
 240     my $prior_sibling = $list->sprevious_sibling();
 241
 242     if ( $prior_sibling ) {
 243         # Bail if we've got a Word in front of the List that isn't
 244         # the original 'die' or 'warn' or anything else that isn't
 245         # a comma operator.
 246         if ( $prior_sibling->isa('PPI::Token::Operator') ) {
 247             if ( $prior_sibling ne $COMMA ) {
 248                 return;
 249             }
 250         } elsif ( $prior_sibling != $die_or_warn ) {
 251             return
 252         }
 253     }
 254
 255     my @list_children = $list->schildren();
 256
 257     # If zero children, nothing to look for.
 258     # If multiple children, then PPI is not giving us
 259     # anything we understand.
 260     return if scalar (@list_children) != 1;
 261
 262     my $list_child = $list_children[0];
 263
 264     # If the child isn't an Expression or it is some other subclass
 265     # of Statement, we again don't understand PPI's output.
 266     return if not is_ppi_expression_or_generic_statement($list_child);
 267
 268     my @statement_children = $list_child->schildren();
 269     return if scalar (@statement_children) < 1;
 270
 271     return $statement_children[-1];
 272 }
 273
 274
 275 #-----------------------------------------------------------------------------
 276 Readonly::Hash my %POSTFIX_OPERATORS =>
 277     hashify qw{ if unless while until for foreach };
 278
 279 sub _is_postfix_operator {
 280     my $element = shift;
 281
 282     if (
 283             $element->isa('PPI::Token::Word')
 284         and $POSTFIX_OPERATORS{$element}
 285     ) {
 286         return $TRUE;
 287     }
 288
 289     return $FALSE;
 290 }
 291
 292
 293 Readonly::Array my @SIMPLE_LIST_ELEMENT_TOKEN_CLASSES =>
 294     qw{
 295         PPI::Token::Number
 296         PPI::Token::Word
 297         PPI::Token::DashedWord
 298         PPI::Token::Symbol
 299         PPI::Token::Quote
 300     };
 301
 302 sub _is_simple_list_element_token {
 303     my $element = shift;
 304
 305     return $FALSE if not $element->isa('PPI::Token');
 306
 307     foreach my $class (@SIMPLE_LIST_ELEMENT_TOKEN_CLASSES) {
 308         return $TRUE if $element->isa($class);
 309     }
 310
 311     return $FALSE;
 312 }
 313
 314
 315 #-----------------------------------------------------------------------------
 316 # Tokens that can't possibly be part of an expression simple
 317 # enough for us to examine.
 318
 319 Readonly::Array my @COMPLEX_EXPRESSION_TOKEN_CLASSES =>
 320     qw{
 321         PPI::Token::ArrayIndex
 322         PPI::Token::QuoteLike
 323         PPI::Token::Regexp
 324         PPI::Token::HereDoc
 325         PPI::Token::Cast
 326         PPI::Token::Label
 327         PPI::Token::Separator
 328         PPI::Token::Data
 329         PPI::Token::End
 330         PPI::Token::Prototype
 331         PPI::Token::Attribute
 332         PPI::Token::Unknown
 333     };
 334
 335 sub _is_complex_expression_token {
 336     my $element = shift;
 337
 338     return $FALSE if not $element->isa('PPI::Token');
 339
 340     foreach my $class (@COMPLEX_EXPRESSION_TOKEN_CLASSES) {
 341         return $TRUE if $element->isa($class);
 342     }
 343
 344     return $FALSE;
 345 }
 346
 347 1;
 348
 349 __END__
 350
 351 #-----------------------------------------------------------------------------
 352
 353 =pod
 354
 355 =head1 NAME
 356
 357 Perl::Critic::Policy::ErrorHandling::RequireCarping - Use functions from L<Carp> instead of C<warn> or C<die>.
 358
 359 =head1 AFFILIATION
 360
 361 This Policy is part of the core L<Perl::Critic> distribution.
 362
 363
 364 =head1 DESCRIPTION
 365
 366 The C<die> and C<warn> functions both report the file and line number
 367 where the exception occurred.  But if someone else is using your
 368 subroutine, they usually don't care where B<your> code blew up.
 369 Instead, they want to know where B<their> code invoked the subroutine.
 370 The L<Carp> module provides alternative methods that report the
 371 exception from the caller's file and line number.
 372
 373 By default, this policy will not complain about C<die> or C<warn>, if
 374 it can determine that the message will always result in a terminal
 375 newline.  Since perl suppresses file names and line numbers in this
 376 situation, it is assumed that no stack traces are desired either and
 377 none of the L<Carp> functions are necessary.
 378
 379     die "oops" if $explosion;             #not ok
 380     warn "Where? Where?!" if $tiger;      #not ok
 381
 382     open my $mouth, '<', 'food'
 383         or die 'of starvation';           #not ok
 384
 385     if (! $dentist_appointment) {
 386         warn "You have bad breath!\n";    #ok
 387     }
 388
 389     die "$clock not set.\n" if $no_time;  #ok
 390
 391     my $message = "$clock not set.\n";
 392     die $message if $no_time;             #not ok, not obvious
 393
 394
 395 =head1 CONFIGURATION
 396
 397 If you give this policy an C<allow_messages_ending_with_newlines>
 398 option in your F<.perlcriticrc> with a false value, then this policy
 399 will disallow all uses of C<die> and C<warn>.
 400
 401     [ErrorHandling::RequireCarping]
 402     allow_messages_ending_with_newlines = 0
 403
 404
 405 =head1 SEE ALSO
 406
 407 L<Carp::Always>
 408
 409 =head1 AUTHOR
 410
 411 Jeffrey Ryan Thalhammer <thaljef@cpan.org>
 412
 413 =head1 COPYRIGHT
 414
 415 Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer.  All rights reserved.
 416
 417 This program is free software; you can redistribute it and/or modify
 418 it under the same terms as Perl itself.  The full text of this license
 419 can be found in the LICENSE file included with this module.
 420
 421 =cut
 422
 423 # Local Variables:
 424 #   mode: cperl
 425 #   cperl-indent-level: 4
 426 #   fill-column: 78
 427 #   indent-tabs-mode: nil
 428 #   c-indentation-style: bsd
 429 # End:
 430 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :