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

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Utils.pm $
   3 #     $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
   4 #   $Author: clonezone $
   5 # $Revision: 2489 $
   6 ##############################################################################
   7
   8 # NOTE: This module is way too large.  Please think about adding new
   9 # functionality into a P::C::Utils::* module instead.
  10
  11 package Perl::Critic::Utils;
  12
  13 use 5.006001;
  14 use strict;
  15 use warnings;
  16 use Readonly;
  17
  18 use File::Spec qw();
  19 use Scalar::Util qw( blessed );
  20 use B::Keywords qw();
  21 use PPI::Token::Quote::Single;
  22
  23 use Perl::Critic::Exception::Fatal::Generic qw{ throw_generic };
  24 use Perl::Critic::Utils::PPI qw< is_ppi_expression_or_generic_statement >;
  25
  26 use base 'Exporter';
  27
  28 our $VERSION = '1.088';
  29
  30 #-----------------------------------------------------------------------------
  31 # Exportable symbols here.
  32
  33 Readonly::Array our @EXPORT_OK => qw(
  34     $TRUE
  35     $FALSE
  36
  37     $POLICY_NAMESPACE
  38
  39     $SEVERITY_HIGHEST
  40     $SEVERITY_HIGH
  41     $SEVERITY_MEDIUM
  42     $SEVERITY_LOW
  43     $SEVERITY_LOWEST
  44     @SEVERITY_NAMES
  45
  46     $DEFAULT_VERBOSITY
  47     $DEFAULT_VERBOSITY_WITH_FILE_NAME
  48
  49     $COLON
  50     $COMMA
  51     $DQUOTE
  52     $EMPTY
  53     $FATCOMMA
  54     $PERIOD
  55     $PIPE
  56     $QUOTE
  57     $BACKTICK
  58     $SCOLON
  59     $SPACE
  60     $SLASH
  61     $BSLASH
  62     $LEFT_PAREN
  63     $RIGHT_PAREN
  64
  65     all_perl_files
  66     find_keywords
  67     first_arg
  68     hashify
  69     interpolate
  70     is_class_name
  71     is_function_call
  72     is_hash_key
  73     is_in_void_context
  74     is_included_module_name
  75     is_integer
  76     is_label_pointer
  77     is_method_call
  78     is_package_declaration
  79     is_perl_bareword
  80     is_perl_builtin
  81     is_perl_builtin_with_list_context
  82     is_perl_builtin_with_multiple_arguments
  83     is_perl_builtin_with_no_arguments
  84     is_perl_builtin_with_one_argument
  85     is_perl_builtin_with_optional_argument
  86     is_perl_builtin_with_zero_and_or_one_arguments
  87     is_perl_filehandle
  88     is_perl_global
  89     is_qualified_name
  90     is_script
  91     is_subroutine_name
  92     is_unchecked_call
  93     is_valid_numeric_verbosity
  94     parse_arg_list
  95     policy_long_name
  96     policy_short_name
  97     precedence_of
  98     severity_to_number
  99     shebang_line
 100     split_nodes_on_comma
 101     verbosity_to_format
 102     words_from_string
 103 );
 104
 105
 106 # Note: this is deprecated.
 107 Readonly::Array our @EXPORT => @EXPORT_OK;  ## no critic (ProhibitAutomaticExport)
 108
 109
 110 Readonly::Hash our %EXPORT_TAGS => (
 111     all             => [ @EXPORT_OK ],
 112     booleans        => [ qw{ $TRUE $FALSE } ],
 113     severities      => [
 114         qw{
 115             $SEVERITY_HIGHEST
 116             $SEVERITY_HIGH
 117             $SEVERITY_MEDIUM
 118             $SEVERITY_LOW
 119             $SEVERITY_LOWEST
 120             @SEVERITY_NAMES
 121         }
 122     ],
 123     characters      => [
 124         qw{
 125             $COLON
 126             $COMMA
 127             $DQUOTE
 128             $EMPTY
 129             $FATCOMMA
 130             $PERIOD
 131             $PIPE
 132             $QUOTE
 133             $BACKTICK
 134             $SCOLON
 135             $SPACE
 136             $SLASH
 137             $BSLASH
 138             $LEFT_PAREN
 139             $RIGHT_PAREN
 140         }
 141     ],
 142     classification  => [
 143         qw{
 144             is_class_name
 145             is_function_call
 146             is_hash_key
 147             is_included_module_name
 148             is_integer
 149             is_label_pointer
 150             is_method_call
 151             is_package_declaration
 152             is_perl_bareword
 153             is_perl_builtin
 154             is_perl_filehandle
 155             is_perl_global
 156             is_perl_builtin_with_list_context
 157             is_perl_builtin_with_multiple_arguments
 158             is_perl_builtin_with_no_arguments
 159             is_perl_builtin_with_one_argument
 160             is_perl_builtin_with_optional_argument
 161             is_perl_builtin_with_zero_and_or_one_arguments
 162             is_qualified_name
 163             is_script
 164             is_subroutine_name
 165             is_unchecked_call
 166             is_valid_numeric_verbosity
 167         }
 168     ],
 169     data_conversion => [ qw{ hashify words_from_string interpolate } ],
 170     ppi             => [ qw{ first_arg parse_arg_list } ],
 171     internal_lookup => [ qw{ severity_to_number verbosity_to_format } ],
 172     language        => [ qw{ precedence_of } ],
 173     deprecated      => [ qw{ find_keywords } ],
 174 );
 175
 176 #-----------------------------------------------------------------------------
 177
 178 Readonly::Scalar our $POLICY_NAMESPACE => 'Perl::Critic::Policy';
 179
 180 #-----------------------------------------------------------------------------
 181
 182 Readonly::Scalar our $SEVERITY_HIGHEST => 5;
 183 Readonly::Scalar our $SEVERITY_HIGH    => 4;
 184 Readonly::Scalar our $SEVERITY_MEDIUM  => 3;
 185 Readonly::Scalar our $SEVERITY_LOW     => 2;
 186 Readonly::Scalar our $SEVERITY_LOWEST  => 1;
 187
 188 #-----------------------------------------------------------------------------
 189
 190 Readonly::Scalar our $COMMA        => q{,};
 191 Readonly::Scalar our $FATCOMMA     => q{=>};
 192 Readonly::Scalar our $COLON        => q{:};
 193 Readonly::Scalar our $SCOLON       => q{;};
 194 Readonly::Scalar our $QUOTE        => q{'};
 195 Readonly::Scalar our $DQUOTE       => q{"};
 196 Readonly::Scalar our $BACKTICK     => q{`};
 197 Readonly::Scalar our $PERIOD       => q{.};
 198 Readonly::Scalar our $PIPE         => q{|};
 199 Readonly::Scalar our $SPACE        => q{ };
 200 Readonly::Scalar our $SLASH        => q{/};
 201 Readonly::Scalar our $BSLASH       => q{\\};
 202 Readonly::Scalar our $LEFT_PAREN   => q{(};
 203 Readonly::Scalar our $RIGHT_PAREN  => q{)};
 204 Readonly::Scalar our $EMPTY        => q{};
 205 Readonly::Scalar our $TRUE         => 1;
 206 Readonly::Scalar our $FALSE        => 0;
 207
 208 #-----------------------------------------------------------------------------
 209
 210 #TODO: Should this include punctuations vars?
 211
 212
 213
 214 #-----------------------------------------------------------------------------
 215 ## no critic (ProhibitNoisyQuotes);
 216
 217 Readonly::Hash my %PRECEDENCE_OF => (
 218   '->'  => 1,       '<'    => 10,      '//'  => 15,     '.='  => 19,
 219   '++'  => 2,       '>'    => 10,      '||'  => 15,     '^='  => 19,
 220   '--'  => 2,       '<='   => 10,      '..'  => 16,     '<<=' => 19,
 221   '**'  => 3,       '>='   => 10,      '...' => 17,     '>>=' => 19,
 222   '!'   => 4,       'lt'   => 10,      '?'   => 18,     ','   => 20,
 223   '~'   => 4,       'gt'   => 10,      ':'   => 18,     '=>'  => 20,
 224   '\\'  => 4,       'le'   => 10,      '='   => 19,     'not' => 22,
 225   '=~'  => 5,       'ge'   => 10,      '+='  => 19,     'and' => 23,
 226   '!~'  => 5,       '=='   => 11,      '-='  => 19,     'or'  => 24,
 227   '*'   => 6,       '!='   => 11,      '*='  => 19,     'xor' => 24,
 228   '/'   => 6,       '<=>'  => 11,      '/='  => 19,
 229   '%'   => 6,       'eq'   => 11,      '%='  => 19,
 230   'x'   => 6,       'ne'   => 11,      '||=' => 19,
 231   '+'   => 7,       'cmp'  => 11,      '&&=' => 19,
 232   '-'   => 7,       '&'    => 12,      '|='  => 19,
 233   '.'   => 7,       '|'    => 13,      '&='  => 19,
 234   '<<'  => 8,       '^'    => 13,      '**=' => 19,
 235   '>>'  => 8,       '&&'   => 14,      'x='  => 19,
 236 );
 237
 238 ## use critic
 239 #-----------------------------------------------------------------------------
 240
 241 sub hashify {  ##no critic(ArgUnpacking)
 242     return map { $_ => 1 } @_;
 243 }
 244
 245 #-----------------------------------------------------------------------------
 246
 247 sub interpolate {
 248     my ( $literal ) = @_;
 249     return eval "\"$literal\"";  ## no critic 'StringyEval';
 250 }
 251
 252 #-----------------------------------------------------------------------------
 253
 254 sub find_keywords {
 255     my ( $doc, $keyword ) = @_;
 256     my $nodes_ref = $doc->find('PPI::Token::Word');
 257     return if !$nodes_ref;
 258     my @matches = grep { $_ eq $keyword } @{$nodes_ref};
 259     return @matches ? \@matches : undef;
 260 }
 261
 262 #-----------------------------------------------------------------------------
 263
 264 sub _name_for_sub_or_stringified_element {
 265     my $elem = shift;
 266
 267     if ( blessed $elem and $elem->isa('PPI::Statement::Sub') ) {
 268         return $elem->name();
 269     }
 270
 271     return "$elem";
 272 }
 273
 274 #-----------------------------------------------------------------------------
 275 ## no critic (ProhibitPackageVars)
 276
 277 Readonly::Hash my %BUILTINS => hashify( @B::Keywords::Functions );
 278
 279 sub is_perl_builtin {
 280     my $elem = shift;
 281     return if !$elem;
 282
 283     return exists $BUILTINS{ _name_for_sub_or_stringified_element($elem) };
 284 }
 285
 286 #-----------------------------------------------------------------------------
 287
 288 Readonly::Hash my %BAREWORDS => hashify( @B::Keywords::Barewords );
 289
 290 sub is_perl_bareword {
 291     my $elem = shift;
 292     return if !$elem;
 293
 294     return exists $BAREWORDS{ _name_for_sub_or_stringified_element($elem) };
 295 }
 296
 297 #-----------------------------------------------------------------------------
 298
 299 sub _build_globals_without_sigils {
 300     my @globals = map { substr $_, 1 }  @B::Keywords::Arrays,
 301                                         @B::Keywords::Hashes,
 302                                         @B::Keywords::Scalars;
 303
 304     # Not all of these have sigils
 305     foreach my $filehandle (@B::Keywords::Filehandles) {
 306         (my $stripped = $filehandle) =~ s< \A [*] ><>xms;
 307         push @globals, $stripped;
 308     }
 309
 310     return @globals;
 311 }
 312
 313 Readonly::Array my @GLOBALS_WITHOUT_SIGILS => _build_globals_without_sigils();
 314
 315 Readonly::Hash my %GLOBALS => hashify( @GLOBALS_WITHOUT_SIGILS );
 316
 317 sub is_perl_global {
 318     my $elem = shift;
 319     return if !$elem;
 320     my $var_name = "$elem"; #Convert Token::Symbol to string
 321     $var_name =~ s{\A [\$@%*] }{}mx;  #Chop off the sigil
 322     return exists $GLOBALS{ $var_name };
 323 }
 324
 325 #-----------------------------------------------------------------------------
 326
 327 Readonly::Hash my %FILEHANDLES => hashify( @B::Keywords::Filehandles );
 328
 329 sub is_perl_filehandle {
 330     my $elem = shift;
 331     return if !$elem;
 332
 333     return exists $FILEHANDLES{ _name_for_sub_or_stringified_element($elem) };
 334 }
 335
 336 ## use critic
 337 #-----------------------------------------------------------------------------
 338
 339 # egrep '=item.*LIST' perlfunc.pod
 340 Readonly::Hash my %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT =>
 341     hashify(
 342         qw{
 343             chmod
 344             chown
 345             die
 346             exec
 347             formline
 348             grep
 349             import
 350             join
 351             kill
 352             map
 353             no
 354             open
 355             pack
 356             print
 357             printf
 358             push
 359             reverse
 360             say
 361             sort
 362             splice
 363             sprintf
 364             syscall
 365             system
 366             tie
 367             unlink
 368             unshift
 369             use
 370             utime
 371             warn
 372         },
 373     );
 374
 375 sub is_perl_builtin_with_list_context {
 376     my $elem = shift;
 377
 378     return
 379         exists
 380             $BUILTINS_WHICH_PROVIDE_LIST_CONTEXT{
 381                 _name_for_sub_or_stringified_element($elem)
 382             };
 383 }
 384
 385 #-----------------------------------------------------------------------------
 386
 387 # egrep '=item.*[A-Z],' perlfunc.pod
 388 Readonly::Hash my %BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS =>
 389     hashify(
 390         qw{
 391             accept
 392             atan2
 393             bind
 394             binmode
 395             bless
 396             connect
 397             crypt
 398             dbmopen
 399             fcntl
 400             flock
 401             gethostbyaddr
 402             getnetbyaddr
 403             getpriority
 404             getservbyname
 405             getservbyport
 406             getsockopt
 407             index
 408             ioctl
 409             link
 410             listen
 411             mkdir
 412             msgctl
 413             msgget
 414             msgrcv
 415             msgsnd
 416             open
 417             opendir
 418             pipe
 419             read
 420             recv
 421             rename
 422             rindex
 423             seek
 424             seekdir
 425             select
 426             semctl
 427             semget
 428             semop
 429             send
 430             setpgrp
 431             setpriority
 432             setsockopt
 433             shmctl
 434             shmget
 435             shmread
 436             shmwrite
 437             shutdown
 438             socket
 439             socketpair
 440             splice
 441             split
 442             substr
 443             symlink
 444             sysopen
 445             sysread
 446             sysseek
 447             syswrite
 448             truncate
 449             unpack
 450             vec
 451             waitpid
 452         },
 453         keys %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT
 454     );
 455
 456 sub is_perl_builtin_with_multiple_arguments {
 457     my $elem = shift;
 458
 459     return
 460         exists
 461             $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{
 462                 _name_for_sub_or_stringified_element($elem)
 463             };
 464 }
 465
 466 #-----------------------------------------------------------------------------
 467
 468 Readonly::Hash my %BUILTINS_WHICH_TAKE_NO_ARGUMENTS =>
 469     hashify(
 470         qw{
 471             endgrent
 472             endhostent
 473             endnetent
 474             endprotoent
 475             endpwent
 476             endservent
 477             fork
 478             format
 479             getgrent
 480             gethostent
 481             getlogin
 482             getnetent
 483             getppid
 484             getprotoent
 485             getpwent
 486             getservent
 487             setgrent
 488             setpwent
 489             split
 490             time
 491             times
 492             wait
 493             wantarray
 494         }
 495     );
 496
 497 sub is_perl_builtin_with_no_arguments {
 498     my $elem = shift;
 499
 500     return
 501         exists
 502             $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{
 503                 _name_for_sub_or_stringified_element($elem)
 504             };
 505 }
 506
 507 #-----------------------------------------------------------------------------
 508
 509 Readonly::Hash my %BUILTINS_WHICH_TAKE_ONE_ARGUMENT =>
 510     hashify(
 511         qw{
 512             closedir
 513             dbmclose
 514             delete
 515             each
 516             exists
 517             fileno
 518             getgrgid
 519             getgrnam
 520             gethostbyname
 521             getnetbyname
 522             getpeername
 523             getpgrp
 524             getprotobyname
 525             getprotobynumber
 526             getpwnam
 527             getpwuid
 528             getsockname
 529             goto
 530             keys
 531             local
 532             prototype
 533             readdir
 534             readline
 535             readpipe
 536             rewinddir
 537             scalar
 538             sethostent
 539             setnetent
 540             setprotoent
 541             setservent
 542             telldir
 543             tied
 544             untie
 545             values
 546         }
 547     );
 548
 549 sub is_perl_builtin_with_one_argument {
 550     my $elem = shift;
 551
 552     return
 553         exists
 554             $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{
 555                 _name_for_sub_or_stringified_element($elem)
 556             };
 557 }
 558
 559 #-----------------------------------------------------------------------------
 560
 561 ## no critic (ProhibitPackageVars)
 562 Readonly::Hash my %BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT =>
 563     hashify(
 564         grep { not exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $_ } }
 565         grep { not exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $_ } }
 566         grep { not exists $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{ $_ } }
 567         @B::Keywords::Functions
 568     );
 569 ## use critic
 570
 571 sub is_perl_builtin_with_optional_argument {
 572     my $elem = shift;
 573
 574     return
 575         exists
 576             $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{
 577                 _name_for_sub_or_stringified_element($elem)
 578             };
 579 }
 580
 581 #-----------------------------------------------------------------------------
 582
 583 sub is_perl_builtin_with_zero_and_or_one_arguments {
 584     my $elem = shift;
 585
 586     return if not $elem;
 587
 588     my $name = _name_for_sub_or_stringified_element($elem);
 589
 590     return (
 591             exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $name }
 592         or  exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $name }
 593         or  exists $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{ $name }
 594     );
 595 }
 596
 597 #-----------------------------------------------------------------------------
 598
 599 sub is_qualified_name {
 600     my $name = shift;
 601
 602     return if not $name;
 603
 604     return index ( $name, q{::} ) >= 0;
 605 }
 606
 607 #-----------------------------------------------------------------------------
 608
 609 sub precedence_of {
 610     my $elem = shift;
 611     return if !$elem;
 612     return $PRECEDENCE_OF{ ref $elem ? "$elem" : $elem };
 613 }
 614
 615 #-----------------------------------------------------------------------------
 616
 617 sub is_hash_key {
 618     my $elem = shift;
 619     return if !$elem;
 620
 621     #If followed by an argument list, then its a function call, not a literal
 622     return if _is_followed_by_parens($elem);
 623
 624     #Check curly-brace style: $hash{foo} = bar;
 625     my $parent = $elem->parent();
 626     return if !$parent;
 627     my $grandparent = $parent->parent();
 628     return if !$grandparent;
 629     return 1 if $grandparent->isa('PPI::Structure::Subscript');
 630
 631
 632     #Check declarative style: %hash = (foo => bar);
 633     my $sib = $elem->snext_sibling();
 634     return if !$sib;
 635     return 1 if $sib->isa('PPI::Token::Operator') && $sib eq '=>';
 636
 637     return;
 638 }
 639
 640 #-----------------------------------------------------------------------------
 641
 642 sub _is_followed_by_parens {
 643     my $elem = shift;
 644     return if !$elem;
 645
 646     my $sibling = $elem->snext_sibling() || return;
 647     return $sibling->isa('PPI::Structure::List');
 648 }
 649
 650 #-----------------------------------------------------------------------------
 651
 652 sub is_included_module_name {
 653     my $elem  = shift;
 654     return if !$elem;
 655     my $stmnt = $elem->statement();
 656     return if !$stmnt;
 657     return if !$stmnt->isa('PPI::Statement::Include');
 658     return $stmnt->schild(1) == $elem;
 659 }
 660
 661 #-----------------------------------------------------------------------------
 662
 663 sub is_integer {
 664     my ($value) = @_;
 665     return 0 if not defined $value;
 666
 667     return $value =~ m{ \A [+-]? \d+ \z }mx;
 668 }
 669
 670 #-----------------------------------------------------------------------------
 671
 672 sub is_label_pointer {
 673     my $elem = shift;
 674     return if !$elem;
 675
 676     my $statement = $elem->statement();
 677     return if !$statement;
 678
 679     my $psib = $elem->sprevious_sibling();
 680     return if !$psib;
 681
 682     return $statement->isa('PPI::Statement::Break')
 683         && $psib =~ m/(?:redo|goto|next|last)/mxo;
 684 }
 685
 686 #-----------------------------------------------------------------------------
 687
 688 sub is_method_call {
 689     my $elem = shift;
 690     return if !$elem;
 691
 692     return _is_dereference_operator( $elem->sprevious_sibling() );
 693 }
 694
 695 #-----------------------------------------------------------------------------
 696
 697 sub is_class_name {
 698     my $elem = shift;
 699     return if !$elem;
 700
 701     return _is_dereference_operator( $elem->snext_sibling() )
 702         && !_is_dereference_operator( $elem->sprevious_sibling() );
 703 }
 704
 705 #-----------------------------------------------------------------------------
 706
 707 sub _is_dereference_operator {
 708     my $elem = shift;
 709     return if !$elem;
 710
 711     return $elem->isa('PPI::Token::Operator') && $elem eq q{->};
 712 }
 713
 714 #-----------------------------------------------------------------------------
 715
 716 sub is_package_declaration {
 717     my $elem  = shift;
 718     return if !$elem;
 719     my $stmnt = $elem->statement();
 720     return if !$stmnt;
 721     return if !$stmnt->isa('PPI::Statement::Package');
 722     return $stmnt->schild(1) == $elem;
 723 }
 724
 725 #-----------------------------------------------------------------------------
 726
 727 sub is_subroutine_name {
 728     my $elem  = shift;
 729     return if !$elem;
 730     my $sib   = $elem->sprevious_sibling();
 731     return if !$sib;
 732     my $stmnt = $elem->statement();
 733     return if !$stmnt;
 734     return $stmnt->isa('PPI::Statement::Sub') && $sib eq 'sub';
 735 }
 736
 737 #-----------------------------------------------------------------------------
 738
 739 sub is_function_call {
 740     my $elem  = shift;
 741     return if !$elem;
 742
 743     return if is_hash_key($elem);
 744     return if is_method_call($elem);
 745     return if is_class_name($elem);
 746     return if is_subroutine_name($elem);
 747     return if is_included_module_name($elem);
 748     return if is_package_declaration($elem);
 749     return if is_perl_bareword($elem);
 750     return if is_perl_filehandle($elem);
 751     return if is_label_pointer($elem);
 752
 753     return 1;
 754 }
 755
 756 #-----------------------------------------------------------------------------
 757
 758 sub is_script {
 759     my $doc = shift;
 760
 761     return shebang_line($doc) ? 1 : 0;
 762 }
 763
 764 #-----------------------------------------------------------------------------
 765
 766 sub is_in_void_context {
 767     my ($token) = @_;
 768
 769     # If part of a collective, can't be void.
 770     return if $token->sprevious_sibling();
 771
 772     my $parent = $token->statement()->parent();
 773     if ($parent) {
 774         return if $parent->isa('PPI::Structure::List');
 775         return if $parent->isa('PPI::Structure::ForLoop');
 776         return if $parent->isa('PPI::Structure::Condition');
 777         return if $parent->isa('PPI::Structure::Constructor');
 778
 779         my $grand_parent = $parent->parent();
 780         if ($grand_parent) {
 781             return if
 782                     $parent->isa('PPI::Structure::Block')
 783                 and not $grand_parent->isa('PPI::Statement::Compound');
 784         }
 785     }
 786
 787     return $TRUE;
 788 }
 789
 790 #-----------------------------------------------------------------------------
 791
 792 sub policy_long_name {
 793     my ( $policy_name ) = @_;
 794     if ( $policy_name !~ m{ \A $POLICY_NAMESPACE }mx ) {
 795         $policy_name = $POLICY_NAMESPACE . q{::} . $policy_name;
 796     }
 797     return $policy_name;
 798 }
 799
 800 #-----------------------------------------------------------------------------
 801
 802 sub policy_short_name {
 803     my ( $policy_name ) = @_;
 804     $policy_name =~ s{\A $POLICY_NAMESPACE ::}{}mx;
 805     return $policy_name;
 806 }
 807
 808 #-----------------------------------------------------------------------------
 809
 810 sub first_arg {
 811     my $elem = shift;
 812     my $sib  = $elem->snext_sibling();
 813     return if !$sib;
 814
 815     if ( $sib->isa('PPI::Structure::List') ) {
 816
 817         my $expr = $sib->schild(0);
 818         return if !$expr;
 819         return $expr->isa('PPI::Statement') ? $expr->schild(0) : $expr;
 820     }
 821
 822     return $sib;
 823 }
 824
 825 #-----------------------------------------------------------------------------
 826
 827 sub parse_arg_list {
 828     my $elem = shift;
 829     my $sib  = $elem->snext_sibling();
 830     return if !$sib;
 831
 832     if ( $sib->isa('PPI::Structure::List') ) {
 833
 834         #Pull siblings from list
 835         my @list_contents = $sib->schildren();
 836         return if not @list_contents;
 837
 838         my @list_expressions;
 839         foreach my $item (@list_contents) {
 840             if (
 841                 is_ppi_expression_or_generic_statement($item)
 842             ) {
 843                 push
 844                     @list_expressions,
 845                     split_nodes_on_comma( $item->schildren() );
 846             }
 847             else {
 848                 push @list_expressions, $item;
 849             }
 850         }
 851
 852         return @list_expressions;
 853     }
 854     else {
 855
 856         #Gather up remaining nodes in the statement
 857         my $iter     = $elem;
 858         my @arg_list = ();
 859
 860         while ($iter = $iter->snext_sibling() ) {
 861             last if $iter->isa('PPI::Token::Structure') and $iter eq $SCOLON;
 862             push @arg_list, $iter;
 863         }
 864         return split_nodes_on_comma( @arg_list );
 865     }
 866 }
 867
 868 #---------------------------------
 869
 870 sub split_nodes_on_comma {
 871     my @nodes = @_;
 872
 873     my $i = 0;
 874     my @node_stacks;
 875     for my $node (@nodes) {
 876         if (
 877                 $node->isa('PPI::Token::Operator')
 878             and ($node eq $COMMA or $node eq $FATCOMMA)
 879         ) {
 880             if (@node_stacks) {
 881                 $i++; #Move forward to next 'node stack'
 882             }
 883             next;
 884         } elsif ( $node->isa('PPI::Token::QuoteLike::Words' )) {
 885             my $section = $node->{sections}->[0];
 886             my @words = words_from_string(substr $node->content, $section->{position}, $section->{size});
 887             my $loc = $node->location;
 888             for my $word (@words) {
 889                 my $token = PPI::Token::Quote::Single->new(q{'} . $word . q{'});
 890                 $token->{_location} = $loc;
 891                 push @{ $node_stacks[$i++] }, $token;
 892             }
 893             next;
 894         }
 895         push @{ $node_stacks[$i] }, $node;
 896     }
 897     return @node_stacks;
 898 }
 899
 900 #-----------------------------------------------------------------------------
 901
 902 # XXX: You must keep the regular expressions in extras/perlcritic.el in sync
 903 # if you change these.
 904 Readonly::Hash my %FORMAT_OF => (
 905     1 => "%f:%l:%c:%m\n",
 906     2 => "%f: (%l:%c) %m\n",
 907     3 => "%m at %f line %l\n",
 908     4 => "%m at line %l, column %c.  %e.  (Severity: %s)\n",
 909     5 => "%f: %m at line %l, column %c.  %e.  (Severity: %s)\n",
 910     6 => "%m at line %l, near '%r'.  (Severity: %s)\n",
 911     7 => "%f: %m at line %l near '%r'.  (Severity: %s)\n",
 912     8 => "[%p] %m at line %l, column %c.  (Severity: %s)\n",
 913     9 => "[%p] %m at line %l, near '%r'.  (Severity: %s)\n",
 914    10 => "%m at line %l, column %c.\n  %p (Severity: %s)\n%d\n",
 915    11 => "%m at line %l, near '%r'.\n  %p (Severity: %s)\n%d\n",
 916 );
 917
 918 Readonly::Scalar our $DEFAULT_VERBOSITY => 4;
 919 Readonly::Scalar our $DEFAULT_VERBOSITY_WITH_FILE_NAME => 5;
 920 Readonly::Scalar my $DEFAULT_FORMAT => $FORMAT_OF{$DEFAULT_VERBOSITY};
 921
 922 sub is_valid_numeric_verbosity {
 923     my ($verbosity) = @_;
 924
 925     return exists $FORMAT_OF{$verbosity};
 926 }
 927
 928 sub verbosity_to_format {
 929     my ($verbosity) = @_;
 930     return $DEFAULT_FORMAT if not defined $verbosity;
 931     return $FORMAT_OF{abs int $verbosity} || $DEFAULT_FORMAT if is_integer($verbosity);
 932     return interpolate( $verbosity );  #Otherwise, treat as a format spec
 933 }
 934
 935 #-----------------------------------------------------------------------------
 936
 937 Readonly::Hash my %SEVERITY_NUMBER_OF => (
 938    gentle  => 5,
 939    stern   => 4,
 940    harsh   => 3,
 941    cruel   => 2,
 942    brutal  => 1,
 943 );
 944
 945 Readonly::Array our @SEVERITY_NAMES =>  #This is exported!
 946     sort
 947         { $SEVERITY_NUMBER_OF{$a} <=> $SEVERITY_NUMBER_OF{$b} }
 948         keys %SEVERITY_NUMBER_OF;
 949
 950 sub severity_to_number {
 951     my ($severity) = @_;
 952     return _normalize_severity( $severity ) if is_integer( $severity );
 953     my $severity_number = $SEVERITY_NUMBER_OF{lc $severity};
 954
 955     if ( not defined $severity_number ) {
 956         throw_generic qq{Invalid severity: "$severity"};
 957     }
 958
 959     return $severity_number;
 960 }
 961
 962 sub _normalize_severity {
 963     my $s = shift || return $SEVERITY_HIGHEST;
 964     $s = $s > $SEVERITY_HIGHEST ? $SEVERITY_HIGHEST : $s;
 965     $s = $s < $SEVERITY_LOWEST  ? $SEVERITY_LOWEST : $s;
 966     return $s;
 967 }
 968
 969 #-----------------------------------------------------------------------------
 970
 971 Readonly::Array my @skip_dir => qw( CVS RCS .svn _darcs {arch} .bzr _build blib );
 972 Readonly::Hash my %skip_dir => hashify( @skip_dir );
 973
 974 sub all_perl_files {
 975
 976     # Recursively searches a list of directories and returns the paths
 977     # to files that seem to be Perl source code.  This subroutine was
 978     # poached from Test::Perl::Critic.
 979
 980     my @queue      = @_;
 981     my @code_files = ();
 982
 983     while (@queue) {
 984         my $file = shift @queue;
 985         if ( -d $file ) {
 986             opendir my ($dh), $file or next;
 987             my @newfiles = sort readdir $dh;
 988             closedir $dh;
 989
 990             @newfiles = File::Spec->no_upwards(@newfiles);
 991             @newfiles = grep { !$skip_dir{$_} } @newfiles;
 992             push @queue, map { File::Spec->catfile($file, $_) } @newfiles;
 993         }
 994
 995         if ( (-f $file) && ! _is_backup($file) && _is_perl($file) ) {
 996             push @code_files, $file;
 997         }
 998     }
 999     return @code_files;
1000 }
1001
1002
1003 #-----------------------------------------------------------------------------
1004 # Decide if it's some sort of backup file
1005
1006 sub _is_backup {
1007     my ($file) = @_;
1008     return 1 if $file =~ m{ [.] swp \z}mx;
1009     return 1 if $file =~ m{ [.] bak \z}mx;
1010     return 1 if $file =~ m{  ~ \z}mx;
1011     return 1 if $file =~ m{ \A [#] .+ [#] \z}mx;
1012     return;
1013 }
1014
1015 #-----------------------------------------------------------------------------
1016 # Returns true if the argument ends with a perl-ish file
1017 # extension, or if it has a shebang-line containing 'perl' This
1018 # subroutine was also poached from Test::Perl::Critic
1019
1020 sub _is_perl {
1021     my ($file) = @_;
1022
1023     #Check filename extensions
1024     return 1 if $file =~ m{ [.] PL    \z}mx;
1025     return 1 if $file =~ m{ [.] p[lm] \z}mx;
1026     return 1 if $file =~ m{ [.] t     \z}mx;
1027
1028     #Check for shebang
1029     open my $fh, '<', $file or return;
1030     my $first = <$fh>;
1031     close $fh or throw_generic "unable to close $file: $!";
1032
1033     return 1 if defined $first && ( $first =~ m{ \A [#]!.*perl }mx );
1034     return;
1035 }
1036
1037 #-----------------------------------------------------------------------------
1038
1039 sub shebang_line {
1040     my $doc = shift;
1041     my $first_element = $doc->first_element();
1042     return if not $first_element;
1043     return if not $first_element->isa('PPI::Token::Comment');
1044     my $location = $first_element->location();
1045     return if !$location;
1046     # The shebang must be the first two characters in the file, according to
1047     # http://en.wikipedia.org/wiki/Shebang_(Unix)
1048     return if $location->[0] != 1; # line number
1049     return if $location->[1] != 1; # column number
1050     my $shebang = $first_element->content;
1051     return if $shebang !~ m{ \A [#]! }mx;
1052     return $shebang;
1053 }
1054
1055 #-----------------------------------------------------------------------------
1056
1057 sub words_from_string {
1058     my $str = shift;
1059
1060     return split q{ }, $str; # This must be a literal space, not $SPACE
1061 }
1062
1063 #-----------------------------------------------------------------------------
1064
1065 sub is_unchecked_call {
1066     my $elem = shift;
1067
1068     return if not is_function_call( $elem );
1069
1070     # check to see if there's an '=' or 'unless' or something before this.
1071     if( my $sib = $elem->sprevious_sibling() ){
1072         return if $sib;
1073     }
1074
1075
1076     if( my $statement = $elem->statement() ){
1077
1078         # "open or die" is OK.
1079         # We can't check snext_sibling for 'or' since the next siblings are an
1080         # unknown number of arguments to the system call. Instead, check all of
1081         # the elements to this statement to see if we find 'or' or '||'.
1082
1083         my $or_operators = sub  {
1084             my (undef, $elem) = @_;
1085             return if not $elem->isa('PPI::Token::Operator');
1086             return if $elem ne q{or} && $elem ne q{||};
1087             return 1;
1088         };
1089
1090         return if $statement->find( $or_operators );
1091
1092
1093         if( my $parent = $elem->statement()->parent() ){
1094
1095             # Check if we're in an if( open ) {good} else {bad} condition
1096             return if $parent->isa('PPI::Structure::Condition');
1097
1098             # Return val could be captured in data structure and checked later
1099             return if $parent->isa('PPI::Structure::Constructor');
1100
1101             # "die if not ( open() )" - It's in list context.
1102             if ( $parent->isa('PPI::Structure::List') ) {
1103                 if( my $uncle = $parent->sprevious_sibling() ){
1104                     return if $uncle;
1105                 }
1106             }
1107         }
1108     }
1109
1110     return if _is_fatal($elem);
1111
1112     # Otherwise, return. this system call is unchecked.
1113     return 1;
1114 }
1115
1116 sub _is_fatal {
1117     my ($elem) = @_;
1118
1119     my $top = $elem->top;
1120     return if !$top->isa('PPI::Document');
1121     my $includes = $top->find('PPI::Statement::Include');
1122     return if !$includes;
1123     for my $include (@{$includes}) {
1124         next if 'use' ne $include->type;
1125         if ('Fatal' eq $include->module) {
1126             my @args = parse_arg_list($include->schild(1));
1127             for my $arg (@args) {
1128                 return 1 if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string;
1129             }
1130         } elsif ('Fatal::Exception' eq $include->module) {
1131             my @args = parse_arg_list($include->schild(1));
1132             shift @args;  # skip exception class name
1133             for my $arg (@args) {
1134                 return 1 if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string;
1135             }
1136         }
1137     }
1138     return;
1139 }
1140
1141 1;
1142
1143 __END__
1144
1145 =pod
1146
1147 =head1 NAME
1148
1149 Perl::Critic::Utils - General utility subroutines and constants for Perl::Critic and derivative distributions.
1150
1151 =head1 DESCRIPTION
1152
1153 This module provides several static subs and variables that are useful for
1154 developing L<Perl::Critic::Policy> subclasses.  Unless you are writing Policy
1155 modules, you probably don't care about this package.
1156
1157 =head1 IMPORTABLE SUBS
1158
1159 =over 8
1160
1161 =item C<find_keywords( $doc, $keyword )>
1162
1163 B<DEPRECATED:> Since version 0.11, every Policy is evaluated at each element
1164 of the document.  So you shouldn't need to go looking for a particular
1165 keyword.  If you I<do> want to use this, please import it via the
1166 C<:deprecated> tag, rather than directly, to mark the module as needing
1167 updating.
1168
1169 Given a L<PPI::Document> as C<$doc>, returns a reference to an array
1170 containing all the L<PPI::Token::Word> elements that match C<$keyword>.  This
1171 can be used to find any built-in function, method call, bareword, or reserved
1172 keyword.  It will not match variables, subroutine names, literal strings,
1173 numbers, or symbols.  If the document doesn't contain any matches, returns
1174 undef.
1175
1176 =item C<is_perl_global( $element )>
1177
1178 Given a L<PPI::Token::Symbol> or a string, returns true if that token
1179 represents one of the global variables provided by the L<English> module, or
1180 one of the builtin global variables like C<%SIG>, C<%ENV>, or C<@ARGV>.  The
1181 sigil on the symbol is ignored, so things like C<$ARGV> or C<$ENV> will still
1182 return true.
1183
1184 =item C<is_perl_builtin( $element )>
1185
1186 Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1187 if that token represents a call to any of the builtin functions defined in
1188 Perl 5.8.8.
1189
1190 =item C<is_perl_bareword( $element )>
1191
1192 Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1193 if that token represents a bareword (e.g. "if", "else", "sub", "package")
1194 defined in Perl 5.8.8.
1195
1196 =item C<is_perl_filehandle( $element )>
1197
1198 Given a L<PPI::Token::Word>, or string, returns true if that token represents
1199 one of the global filehandles (e.g. C<STDIN>, C<STDERR>, C<STDOUT>, C<ARGV>)
1200 that are defined in Perl 5.8.8.  Note that this function will return false if
1201 given a filehandle that is represented as a typeglob (e.g. C<*STDIN>)
1202
1203 =item C<is_perl_builtin_with_list_context( $element )>
1204
1205 Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1206 if that token represents a call to any of the builtin functions defined in
1207 Perl 5.8.8 that provide a list context to the following tokens.
1208
1209 =item C<is_perl_builtin_with_multiple_arguments( $element )>
1210
1211 Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1212 if that token represents a call to any of the builtin functions defined in
1213 Perl 5.8.8 that B<can> take multiple arguments.
1214
1215 =item C<is_perl_builtin_with_no_arguments( $element )>
1216
1217 Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1218 if that token represents a call to any of the builtin functions defined in
1219 Perl 5.8.8 that B<cannot> take any arguments.
1220
1221 =item C<is_perl_builtin_with_one_argument( $element )>
1222
1223 Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1224 if that token represents a call to any of the builtin functions defined in
1225 Perl 5.8.8 that takes B<one and only one> argument.
1226
1227 =item C<is_perl_builtin_with_optional_argument( $element )>
1228
1229 Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1230 if that token represents a call to any of the builtin functions defined in
1231 Perl 5.8.8 that takes B<no more than one> argument.
1232
1233 The sets of values for which C<is_perl_builtin_with_multiple_arguments()>,
1234 C<is_perl_builtin_with_no_arguments()>,
1235 C<is_perl_builtin_with_one_argument()>, and
1236 C<is_perl_builtin_with_optional_argument()> return true are disjoint and
1237 their union is precisely the set of values that C<is_perl_builtin()> will
1238 return true for.
1239
1240 =item C<is_perl_builtin_with_zero_and_or_one_arguments( $element )>
1241
1242 Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1243 if that token represents a call to any of the builtin functions defined in
1244 Perl 5.8.8 that takes no and/or one argument.
1245
1246 Returns true if any of C<is_perl_builtin_with_no_arguments()>,
1247 C<is_perl_builtin_with_one_argument()>, and
1248 C<is_perl_builtin_with_optional_argument()> returns true.
1249
1250 =item C<is_qualified_name( $name )>
1251
1252 Given a string, L<PPI::Token::Word>, or L<PPI::Token::Symbol>, answers
1253 whether it has a module component, i.e. contains "::".
1254
1255 =item C<precedence_of( $element )>
1256
1257 Given a L<PPI::Token::Operator> or a string, returns the precedence of the
1258 operator, where 1 is the highest precedence.  Returns undef if the precedence
1259 can't be determined (which is usually because it is not an operator).
1260
1261 =item C<is_hash_key( $element )>
1262
1263 Given a L<PPI::Element>, returns true if the element is a literal hash key.
1264 PPI doesn't distinguish between regular barewords (like keywords or subroutine
1265 calls) and barewords in hash subscripts (which are considered literal).  So
1266 this subroutine is useful if your Policy is searching for L<PPI::Token::Word>
1267 elements and you want to filter out the hash subscript variety.  In both of
1268 the following examples, "foo" is considered a hash key:
1269
1270   $hash1{foo} = 1;
1271   %hash2 = (foo => 1);
1272
1273 But if the bareword is followed by an argument list, then perl treats it as a
1274 function call.  So in these examples, "foo" is B<not> considered a hash key:
1275
1276   $hash1{ foo() } = 1;
1277   &hash2 = (foo() => 1);
1278
1279 =item C<is_included_module_name( $element )>
1280
1281 Given a L<PPI::Token::Word>, returns true if the element is the name of a
1282 module that is being included via C<use>, C<require>, or C<no>.
1283
1284 =item C<is_integer( $value )>
1285
1286 Answers whether the parameter, as a string, looks like an integral value.
1287
1288 =item C<is_class_name( $element )>
1289
1290 Given a L<PPI::Token::Word>, returns true if the element that immediately
1291 follows this element is the dereference operator "->". When a bareword has a
1292 "->" on the B<right> side, it usually means that it is the name of the class
1293 (from which a method is being called).
1294
1295 =item C<is_label_pointer( $element )>
1296
1297 Given a L<PPI::Token::Word>, returns true if the element is the label
1298 in a C<next>, C<last>, C<redo>, or C<goto> statement.  Note this is not the
1299 same thing as the label declaration.
1300
1301 =item C<is_method_call( $element )>
1302
1303 Given a L<PPI::Token::Word>, returns true if the element that immediately
1304 precedes this element is the dereference operator "->". When a bareword has a
1305 "->" on the B<left> side, it usually means that it is the name of a method
1306 (that is being called from a class).
1307
1308 =item C<is_package_declaration( $element )>
1309
1310 Given a L<PPI::Token::Word>, returns true if the element is the name of a
1311 package that is being declared.
1312
1313 =item C<is_subroutine_name( $element )>
1314
1315 Given a L<PPI::Token::Word>, returns true if the element is the name of a
1316 subroutine declaration.  This is useful for distinguishing barewords and from
1317 function calls from subroutine declarations.
1318
1319 =item C<is_function_call( $element )>
1320
1321 Given a L<PPI::Token::Word> returns true if the element appears to be call to
1322 a static function.  Specifically, this function returns true if
1323 C<is_hash_key>, C<is_method_call>, C<is_subroutine_name>,
1324 C<is_included_module_anme>, C<is_package_declaration>, C<is_perl_bareword>,
1325 C<is_perl_filehandle>, C<is_label_pointer> and C<is_subroutine_name> all
1326 return false for the given element.
1327
1328 =item C<first_arg( $element )>
1329
1330 Given a L<PPI::Element> that is presumed to be a function call (which is
1331 usually a L<PPI::Token::Word>), return the first argument.  This is similar of
1332 C<parse_arg_list()> and follows the same logic.  Note that for the code:
1333
1334   int($x + 0.5)
1335
1336 this function will return just the C<$x>, not the whole expression.  This is
1337 different from the behavior of C<parse_arg_list()>.  Another caveat is:
1338
1339   int(($x + $y) + 0.5)
1340
1341 which returns C<($x + $y)> as a L<PPI::Structure::List> instance.
1342
1343 =item C<parse_arg_list( $element )>
1344
1345 Given a L<PPI::Element> that is presumed to be a function call (which is
1346 usually a L<PPI::Token::Word>), splits the argument expressions into arrays of
1347 tokens.  Returns a list containing references to each of those arrays.  This
1348 is useful because parentheses are optional when calling a function, and PPI
1349 parses them very differently.  So this method is a poor-man's parse tree of
1350 PPI nodes.  It's not bullet-proof because it doesn't respect precedence.  In
1351 general, I don't like the way this function works, so don't count on it to be
1352 stable (or even present).
1353
1354 =item C<split_nodes_on_comma( @nodes )>
1355
1356 This has the same return type as C<parse_arg_list()> but expects to be passed
1357 the nodes that represent the interior of a list, like:
1358
1359   'foo', 1, 2, 'bar'
1360
1361 =item C<is_script( $document )>
1362
1363 Given a L<PPI::Document>, test if it starts with C</#!.*/>.  If so, it is
1364 judged to be a script instead of a module.  See C<shebang_line()>.
1365
1366 =item C<is_in_void_context( $token )>
1367
1368 Given a L<PPI::Token>, answer whether it appears to be in a void context.
1369
1370 =item C<policy_long_name( $policy_name )>
1371
1372 Given a policy class name in long or short form, return the long form.
1373
1374 =item C<policy_short_name( $policy_name )>
1375
1376 Given a policy class name in long or short form, return the short form.
1377
1378 =item C<all_perl_files( @directories )>
1379
1380 Given a list of directories, recursively searches through all the directories
1381 (depth first) and returns a list of paths for all the files that are Perl code
1382 files.  Any administrative files for CVS or Subversion are skipped, as are
1383 things that look like temporary or backup files.
1384
1385 A Perl code file is:
1386
1387 =over 4
1388
1389 =item * Any file that ends in F<.PL>, F<.pl>, F<.pm>, or F<.t>
1390
1391 =item * Any file that has a first line with a shebang containing 'perl'
1392
1393 =back
1394
1395 =item C<severity_to_number( $severity )>
1396
1397 If C<$severity> is given as an integer, this function returns C<$severity> but
1398 normalized to lie between C<$SEVERITY_LOWEST> and C<$SEVERITY_HIGHEST>.  If
1399 C<$severity> is given as a string, this function returns the corresponding
1400 severity number.  If the string doesn't have a corresponding number, this
1401 function will throw an exception.
1402
1403 =item C<is_valid_numeric_verbosity( $severity )>
1404
1405 Answers whether the argument has a translation to a Violation format.
1406
1407 =item C<verbosity_to_format( $verbosity_level )>
1408
1409 Given a verbosity level between 1 and 10, returns the corresponding predefined
1410 format string.  These formats are suitable for passing to the C<set_format>
1411 method in L<Perl::Critic::Violation>.  See the L<perlcritic> documentation for
1412 a listing of the predefined formats.
1413
1414 =item C<hashify( @list )>
1415
1416 Given C<@list>, return a hash where C<@list> is in the keys and each value is
1417 1.  Duplicate values in C<@list> are silently squished.
1418
1419 =item C<interpolate( $literal )>
1420
1421 Given a C<$literal> string that may contain control characters (e.g.. '\t'
1422 '\n'), this function does a double interpolation on the string and returns it
1423 as if it had been declared in double quotes.  For example:
1424
1425   'foo \t bar \n' ...becomes... "foo \t bar \n"
1426
1427 =item C<shebang_line( $document )>
1428
1429 Given a L<PPI::Document>, test if it starts with C<#!>.  If so, return that
1430 line.  Otherwise return undef.
1431
1432 =item C<words_from_string( $str )>
1433
1434 Given config string I<$str>, return all the words from the string.  This is
1435 safer than splitting on whitespace.
1436
1437 =item C<is_unchecked_call( $element )>
1438
1439 Given a L<PPI::Element>, test to see if it contains a function call whose
1440 return value is not checked.
1441
1442 =back
1443
1444 =head1 IMPORTABLE VARIABLES
1445
1446 =over 8
1447
1448 =item C<$COMMA>
1449
1450 =item C<$FATCOMMA>
1451
1452 =item C<$COLON>
1453
1454 =item C<$SCOLON>
1455
1456 =item C<$QUOTE>
1457
1458 =item C<$DQUOTE>
1459
1460 =item C<$BACKTICK>
1461
1462 =item C<$PERIOD>
1463
1464 =item C<$PIPE>
1465
1466 =item C<$EMPTY>
1467
1468 =item C<$SPACE>
1469
1470 =item C<$SLASH>
1471
1472 =item C<$BSLASH>
1473
1474 =item C<$LEFT_PAREN>
1475
1476 =item C<$RIGHT_PAREN>
1477
1478 These character constants give clear names to commonly-used strings that can
1479 be hard to read when surrounded by quotes and other punctuation.  Can be
1480 imported in one go via the C<:characters> tag.
1481
1482 =item C<$SEVERITY_HIGHEST>
1483
1484 =item C<$SEVERITY_HIGH>
1485
1486 =item C<$SEVERITY_MEDIUM>
1487
1488 =item C<$SEVERITY_LOW>
1489
1490 =item C<$SEVERITY_LOWEST>
1491
1492 These numeric constants define the relative severity of violating each
1493 L<Perl::Critic::Policy>.  The C<get_severity> and C<default_severity> methods
1494 of every Policy subclass must return one of these values. Can be imported via
1495 the C<:severities> tag.
1496
1497 =item C<$DEFAULT_VERBOSITY>
1498
1499 The default numeric verbosity.
1500
1501 =item C<$DEFAULT_VERBOSITY_WITH_FILE_NAME>
1502
1503 The numeric verbosity that corresponds to the format indicated by
1504 C<$DEFAULT_VERBOSITY>, but with the file name prefixed to it.
1505
1506 =item C<$TRUE>
1507
1508 =item C<$FALSE>
1509
1510 These are simple booleans. 1 and 0 respectively.  Be mindful of using these
1511 with string equality.  C<$FALSE ne $EMPTY>.  Can be imported via the
1512 C<:booleans> tag.
1513
1514 =back
1515
1516 =head1 IMPORT TAGS
1517
1518 The following groups of functions and constants are available as parameters to
1519 a C<use Perl::Critic::Util> statement.
1520
1521 =over
1522
1523 =item C<:all>
1524
1525 The lot.
1526
1527 =item C<:booleans>
1528
1529 Includes:
1530 C<$TRUE>, C<$FALSE>
1531
1532 =item C<:severities>
1533
1534 Includes:
1535 C<$SEVERITY_HIGHEST>,
1536 C<$SEVERITY_HIGH>,
1537 C<$SEVERITY_MEDIUM>,
1538 C<$SEVERITY_LOW>,
1539 C<$SEVERITY_LOWEST>,
1540 C<@SEVERITY_NAMES>
1541
1542 =item C<:characters>
1543
1544 Includes:
1545 C<$COLON>,
1546 C<$COMMA>,
1547 C<$DQUOTE>,
1548 C<$EMPTY>,
1549 C<$FATCOMMA>,
1550 C<$PERIOD>,
1551 C<$PIPE>,
1552 C<$QUOTE>,
1553 C<$BACKTICK>,
1554 C<$SCOLON>,
1555 C<$SPACE>,
1556 C<$SLASH>,
1557 C<$BSLASH>
1558 C<$LEFT_PAREN>
1559 C<$RIGHT_PAREN>
1560
1561 =item C<:classification>
1562
1563 Includes:
1564 C<is_function_call>,
1565 C<is_hash_key>,
1566 C<is_included_module_name>,
1567 C<is_integer>,
1568 C<is_method_call>,
1569 C<is_package_declaration>,
1570 C<is_perl_builtin>,
1571 C<is_perl_global>,
1572 C<is_perl_builtin_with_list_context>
1573 C<is_perl_builtin_with_multiple_arguments>
1574 C<is_perl_builtin_with_no_arguments>
1575 C<is_perl_builtin_with_one_argument>
1576 C<is_perl_builtin_with_optional_argument>
1577 C<is_perl_builtin_with_zero_and_or_one_arguments>
1578 C<is_script>,
1579 C<is_subroutine_name>,
1580 C<is_unchecked_call>
1581 C<is_valid_numeric_verbosity>
1582
1583 See also L<Perl::Critic::Utils::PPI>.
1584
1585 =item C<:data_conversion>
1586
1587 Generic manipulation, not having anything specific to do with Perl::Critic.
1588
1589 Includes:
1590 C<hashify>,
1591 C<words_from_string>,
1592 C<interpolate>
1593
1594 =item C<:ppi>
1595
1596 Things for dealing with L<PPI>, other than classification.
1597
1598 Includes:
1599 C<first_arg>,
1600 C<parse_arg_list>
1601
1602 See also L<Perl::Critic::Utils::PPI>.
1603
1604 =item C<:internal_lookup>
1605
1606 Translations between internal representations.
1607
1608 Includes:
1609 C<severity_to_number>,
1610 C<verbosity_to_format>
1611
1612 =item C<:language>
1613
1614 Information about Perl not programmatically available elsewhere.
1615
1616 Includes:
1617 C<precedence_of>
1618
1619 =item C<:deprecated>
1620
1621 Not surprisingly, things that are deprecated.  It is preferred to use this tag
1622 to get to these functions, rather than the function names themselves, so as to
1623 mark any module using them as needing cleanup.
1624
1625 Includes:
1626 C<find_keywords>
1627
1628 =back
1629
1630 =head1 SEE ALSO
1631
1632 L<Perl::Critic::Utils::Constants>,
1633 L<Perl::Critic::Utils::McCabe>,
1634 L<Perl::Critic::Utils::PPI>,
1635
1636 =head1 AUTHOR
1637
1638 Jeffrey Ryan Thalhammer <thaljef@cpan.org>
1639
1640 =head1 COPYRIGHT
1641
1642 Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer.  All rights reserved.
1643
1644 This program is free software; you can redistribute it and/or modify
1645 it under the same terms as Perl itself.  The full text of this license
1646 can be found in the LICENSE file included with this module.
1647
1648 =cut
1649
1650 # Local Variables:
1651 #   mode: cperl
1652 #   cperl-indent-level: 4
1653 #   fill-column: 78
1654 #   indent-tabs-mode: nil
1655 #   c-indentation-style: bsd
1656 # End:
1657 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :