Hack 83. Write Your Own Warnings

Improve static code checking.

You have strict under control. You know why you use warnings. Maybe you even use B::Lint to find problems. Are they truly enough for you? If you've ever wished that you could make strict stricter or make warnings preachier, you're in luck.

Perl::Critic is a similarly excellent tool that audits your code based on Damian Conway's Perl Best Practices (O'Reilly).

The Hack

It's impossible to override some built-in functions^[19] [Hack #91] like print( ) and printf( ). Usually print( ) succeeds because it writes to an internal bufferbut occasionally Perl has to flush the buffer. print( ) might fail if you write to a file on a full file system, to a closed handle, or for any of several other reasons. If you don't check print( ) and close( ) for success, you might lose data without knowing about it.

^[19] Run perl -MB::Keywords -le 'eval{ prototype $_ } or print for @B::Keywords::Functions' after installing B::Keywords to see a complete list.

The best you can do for unoverridable functions is to create new warnings for unsafe code.

Here's bad_style.pl, a short program that opens a file and writes something to it. It has three misfeatures: ignoring the results of print( ) and close( ) and a terribly non-descriptive variable name:

open my $fh, '>>', 'bad_style.txt'     or die "Can't open bad_style.txt for appending: $!\\n"; print {$fh} 'Hello!'; close $fh;

You could review every line of code in your system to find these errors. Better yet, teach B::Lint how to find them for you:

package B::Lint::VoidSyscalls; use strict; use warnings; use B 'OPf_WANT_VOID'; use B::Lint; # Make B::Lint accept plugins if it doesn't already. use if ! B::Lint->can('register_plugin'),     'B::Lint::Pluggable';                 # Register this plugin. B::Lint->register_plugin( __PACKAGE__, [ 'void_syscall' ] ); # Check these opcodes my $SYSCALL = qr/ ^ (?: open | print | close ) $ /msx; # Also look for things that are right at the end of a subroutine # sub foo { return print( ) } my $TERM = qr/ ^ (?: leavesub ) $/msx; sub match {     my ( $op, $checks ) = @_;     if (     $checks->{void_syscall}          and $op->name( ) =~ m/$SYSCALL/msx )     {         if ( $op->flags() & OPf_WANT_VOID )         {             warn "Unchecked " .  $op->name( ) .  " system call "                 .  "at " .  B::Lint->file( ) .  " on line "                 .  B::Lint->line( ) .  "\\n";         }         elsif ( $op->next->name( ) =~ m/$TERM/msx )         {             warn "Potentially unchecked " .  $op->name( ) .  " system call "                 .  "at " .  B::Lint->file( ) .  " on line "                 .  B::Lint->line( ) .  "\\n";         }     } }

As of Perl 5.9.3, B::Lint supports plugins. Earlier versions don't, so this code checks the version and loads a fallback if necessary.

This module also checks for system calls made in potentially void context at the end of functionsthat is, where the next opcode is leavesub.

Running the Hack

Checking bad_style.pl with B::Lint::VoidSyscalls is easy:

$ perl -MB::Lint::VoidSyscalls -MO=Lint bad_style.pl Unchecked print system call at bad_style.pl on line 3 Unchecked close system call at bad_style.pl on line 4 bad_style.pl syntax OK

Hacking the Hack

The idea is pretty general: find bad stuff in the optree ("Find All Global Variables" [Hack #77] shows how to mine the optree) and tell the user about it. There are plenty of possibilities to add more strictness to your OO codechecking that a class actually exists for class method calls, that the methods being called on those classes exist, and even that the methods being called are appropriate methods for certain classes. Here's an alternate match( ) subroutine that does just that:

sub match {     my $op = shift;     if ( $op->name() eq 'entersub' )     {         my $class  = eval { $op->first->sibling         ->sv->PV };         my $method = eval { $op->first->sibling->sibling->sv->PV };         if ( defined $class )         {             no strict 'refs';             # check strict classes             if ( not %{ $class . '::' } )             {                 B::Lint::warning "Class $class doesn't exist";             }             # check strict class methods             elsif ( defined $method and not $class->can($method) )             {                 B::Lint::warning "Class $class can't do method $method";             }         }         elsif (     defined $method                 and not grep { $_->can($method) } classes( B::Lint->file() ) )         {             B::Lint::warning "Object can't do method $method";         }     } } use File::Slurp 'read_file'; my %classes; sub classes {     my $file = shift;     $classes{$file} ||= scalar {         map { $_ => 1 }         grep { defined %{ $_ . '::' } }         read_file($file) =~ m/( \\w+ (?: (?:::|')\\w+ )* )/msxg     };     return keys %{ $classes{$file} }; }