Perl hacks were the subject of the August 10, 2006 meeting. If you have any interesting perl hackery you've done recently, feel free to post it here.

Calling a Function Using the 'Anonymous Subroutine' Prototype.

Here was the hack I brought with me. It uses a bit of an obscure perl feature to get some expressive results. Normally in perl one does not need to use or think about subroutine prototypes, however, here's a case where subroutine prototypes allow you to generate new perl syntax, allowing you to add brevity and clarity to otherwise tedious and ugly constructs. Much credit goes to Mark Jason Dominus (see his book Higher Order Perl) and Damien Conway (see Perl Best Practices).

The basic premise is using a prototyped subroutine with a bare ampersand as the first argument in the prototype. Note that since it's bare, the & is 'magical'. You work the magic when you pass in a reference to an anonymous subroutine. Below is an example:

sub foo (&) {
    my $subref = shift;
    ## do stuff
}

How would you call this function? One of many ways:

## You could pass in a ref to a named function:
sub ack { print "hello\n"  }
foo(\&ack);      

## Or, you could create a ref to a subroutine, pass it in: 
my $ack = sub { print "hello\n"};
foo($ack);

## (the same as above, but shorter)
foo( sub { print "hello"\n } );  

The final way to call 'foo' is an interesting piece of perl arcana. This is the syntactic sugar that the prototype provides:

##  note the construct is surrounded by squiggly brackets!

foo {               
    print "hello\n";
}                    

All the code between the squigglies gets shoved into foo as a reference to an anonymous subroutine. This allows you to do all sorts of crazy stuff. Consider:

sub TRY (&) {
    my $subref = shift;   ## shift ref to subroutine off the stack
    eval { $subref->() };  ## execute the subroutine, catch exceptions.
    if ($@) {
        ## handle the error in your own special way.
    }
}

Now, the usage:

TRY {
    my_function_that_dies();
    my_other_function_that_may_die_too();
    get_beer_in_fridge() || die "I could not find any beer. noooooo!";
};

You've effictively cut out the ugly "if ($@)" kruft out of your controlling code.

Example: Database Transaction Safe Block.

Here's a more interesting example. A function that provides a database transaction safe block. Lets assume we have at our disposal a function called 'handle()' which provides you the currently existing connection to your db.

sub TRANS (&) {
    my $dbh = handle();
    eval { shift->() };

    if ($@) {
        $dbh->rollback;
        ## handle your error here        
    }
    else {
        $dbh->commit;
    }
}

Now, the usage:

TRANS {
    $dbh = handle();
    $dbh->do_stuff || die "I died doing some sql";
    $dbh->do_more_stuff || die "Oh no, I died aaaarrrrg";
};

Your rollback or commit is transparently provided by the TRANS function.

Example: Eval Style Version of TRANS

Let's make TRANS context aware, so that we can explicitly tell TRANS whether we want to examine an error or not. We can use wantarray for that.

sub TRANS (&) {
    my $dbh = handle();
    eval { shift->() };

    if ($@) {
        my $e = $@;      ## localize this for safety.
        $dbh->rollback; ## rollback as advertised

        ## check the context we were called in:
        if (defined wantarray) {
            ## called in scalar context
            return $e;
        }
        else {
            ## handle your error here, maybe rethrow exception?  
        }        
    }
    else {
        $dbh->commit;
    }
}

And the usage:

## In this case, we'll always get back $e to examine
my $e = TRANS {
    go_to_fridge();
    sql_call_to_get_beer_contents();
    have_beer() || do { weep() && die("Arrrrgh I need beer") };                    
};

## examine $e, determine what to do here.

## in this case, TRANS will handle the error.
TRANS {
    go_to_fridge();
    sql_call_to_get_beer_contents();
    have_beer() || do { weep() && die("Arrrrgh I need beer") };                    
};

Let's go overboard. You have multiple 'handle()' functions, each of which return existing connections to different databases - handle1(), handle2(), handle3(). You want transaction safe blocks for all of them, but like a good lazy programmer you loathe cutting and pasting. So that begs the question ... why write perl when you can have perl write perl for you?

The function below generates functions that provide transaction safe blocks which implicitly have access to the correct db handle.

sub gen_tx_safe_subroutine {
    my $handle_sub = shift; 

    return sub (&) {    ## <-- note the prototype on the anonymous sub 
        eval { shift->() };
        my $dbh = $handle_sub->();

        if ($@) {
            $dbh->rollback;
        ....
        ....
        ## etc

    }
}

Usage:

package foo;

BEGIN {
    ## have perl create the subroutines for you:
    *TRANS1 = gen_tx_safe_subroutine(\&handle1);
    *TRANS2 = gen_tx_safe_subroutine(\&handle2);
    *TRANS3 = gen_tx_safe_subroutine(\&handle3);
}

## use as normal:

TRANS1 {
   do_sql_stuff();
};

TRANS2 {
  do_other_sql_stuff();
};

TRANS3 {
 do_still_other_sql_stuff()
};

OK, thats all for my hack. Feel free to add your own hack to this page.

-- Main.Matt - 11 Aug 2006

Proposed modification to Pod::Checker

The attached file (unified diff) against CPAN module Pod::Checker (Version 1.43) is an attempt to make two things happen:

• Produce a Warning when only the

  =cut

  command is found.
• Produce a Warning when a Pod command is found without a blank line preceding.

This is to identify Perl files (scripts, modules) that will go thru podchecker cleanly (rc=0 to shell), but will produce no actual documentation. The latter is triggered by sending "-warning" thrice to podchecker (or by having your own Pod::Checker front-end script set, e.g., options like -warnings => 3). Code snippets follow (new code in bluer text):

sub initialize {
    my $self = shift;
    ## Initialize number of errors, and setup an error function to
    ## increment this number and then print to the designated output.
    $self->{_NUM_ERRORS} = 0;
    $self->{_NUM_WARNINGS} = 0;
 #-----%<-------%<-------------------------------

    $self->{-want_nonPODs} = 0 unless(defined $self->{-want_nonPODs});
    # Following provides alternative to explicitly stating
    # "-want_nonPODs => 1" in calling script.
    $self->{-want_nonPODs} = 1 if $self->{-warnings}>2;
    $self->parseopts(
        -process_cut_cmd => 1,
        -warnings => $self->{-warnings},
        -want_nonPODs => $self->{-want_nonPODs},
    );

    # To hold state: Did we have Pod, (not =cut) before =cut?
    $self->{_any_Pod_substance} = 0;
}
#-----%<-------%<-------------------------------

sub preprocess_paragraph {
    my ($self, $text, $line_num) = @_;
    #if ($text =~ /\A=for comment\z/) {
    if ($text =~ /^=for comment/) {
        #warn "Ignoring comment : $text\n";
        return $text;
    }
    else {
        while ($text =~ /[\r\n](={1,2}\S+)/g) {
            my $errorsub = $self->errorsub();
            my $file = $self->input_file();
            my $errmsg = "Need a Blank Line before $1";
            #" Block begins at line $line_num\n";
            $self->poderror(
                { 
                    -line => $line_num,-file => $file,
                    -severity => 'WARNING', 
                    -msg => $errmsg,
                }
            );
        } 
    }
    #warn "Processing $text";
    return  $text;
}

sub end_pod {
    ## Do some final checks and
    ## print the number of errors found
    my $self   = shift;
------%<--------------------%<-----------
    # no POD found here
    $self->num_errors(-1) if($self->{_commands} == 0);

    # set warning here if only have =cut (one or more)
    if (($self->num_errors() == 0) && (! $self->{_any_Pod_substance})) {
        $self->poderror(
            {
                -line => 'EOF', -file => $infile,
                -severity => 'WARNING', 
                -msg => "File with only =cut(s) will produce no Pod!!",
            }
        );
    } 
}

sub command { 
    my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
    my ($file, $line) = $pod_para->file_line;
    ## Check the command syntax
    my $arg; # this will hold the command argument
    if (! $VALID_COMMANDS{$cmd}) {
       $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR',
                         -msg => "Unknown command '$cmd'" });
    }
    else { # found a valid command
        $self->{_commands}++; # delete this line if below is enabled again

        ##### following check disabled due to strong request
        #if(!$self->{_commands}++ && $cmd !~ /^head/) {
        #    $self->poderror({ -line => $line, -file => $file,
        #         -severity => 'WARNING', 
        #         -msg => "file does not start with =head" });
        #}

        # To know whether something valid precedes =cut. Note: this ignores
        # the fact the the command here might subsequently error out.
        if ($cmd ne 'cut') {
            $self->{_any_Pod_substance} = 1;
        }

Suggestions/ Comments /Constructive criticism welcome.

-- JohnIngersoll - 06 May 2008

• Checker.diff: Unified diff (4 lines of context)