Wednesday, April 17, 2013

Auto-generating setters and getters in Perl with Moose

As part of a project for work interfacing with the RDS encoder for the radio station (an Inovonics Model 730) I thought, "wouldn't it be nice to have a Perl object that provides a complete interface to this device?"  The only trouble is that the device takes a lot of different commands, and it would be really tedious to write sub set_foo { ... }; sub get_foo { ... } umpteen million times for every last command / datum the encoder supported, since every set_foo { ... } was going to boil down to:

sub set_foo {
    my ($self, $value) = @_;
    return _set('foo', $value);
}

sub get_foo {
    my $self = shift;
    return _get('foo');
}

Where _set() and _get() took care of the actual business of communicating with the encoder.

Now, I could have done this in Vim with regular expressions - just copy/paste and use the regex to change the appropriate things. Still tedious, though. I also could have done something like this:

sub set_property {
    my ($self, $property, $value) = @_;
    return _set($property, $value);
}

sub get_property {
    my ($self, $property) = @_;
    return _get($property);
}

And that would have worked fine. I could have put some code in there to throw an exception on an invalid property, maybe something to validate the values based on the property name, all that sort of thing. But Moose gives us a nifty trick to avoid having to validate the property name:

    package MooseSketch;
    use Moose;

    my $meta = __PACKAGE__->meta;
    foreach my $prop (qw/foo bar baz bak/) {
        $meta->add_method(qq/set_$prop/, sub { 
                my $self = shift;
                my $value = shift;
                return $self->_set($prop, $value);
            }
        );
        $meta->add_method(qq/get_$prop/, sub { 
                my $self = shift;
                return $self->_get($prop);
            }
        );
    }

This $meta business comes from Class::MOP::Class, which allows us to do introspection and manipulation of Perl 5 objects. So with Class::MOP::Class, I can add or remove methods programatically at runtime, or even create entire classes. Neat, huh?

Hope you find this useful. I know I sure will. Many thanks to the good people over at Stack Overflow who helped me figure this out. My original question: How to auto-generate a bunch of setters/getters tied to a network service in Moose?

Monday, February 11, 2013

Generating a Word document with Perl and Win32::OLE

I'm about to have to throw this particular bit of code away, as I'm not able to get this to work from Scheduled Tasks on Windows 7.  Before I sent it to the bit bucket, however, I thought I'd post it here with the hope that someone will find it useful.



# Expects arguments as a hashref with the keys:
# # log_date: Date of the log
# # data: an arrayref of arrayrefs.  First line is treated as column headings, following lines are treated as data.
#
# A double horizontal rule will be added between the column headings and the data.
#
# NB: The reason that everything gets its own object (e.g. "my $tables = $doc->Tables; my $table = $tables->Add(...);")
# is not (neccessarily) for "Law of Demeter" reasons, but rather MS recommended practice when
# automating Office applications from Visual Studio (and by extension, OLE): http://support.microsoft.com/kb/317109
# Experimentally, I have noticed instances of the Word executable remaining in memory after program exit;
# refactoring the code in this way is an attempt to deal with that issue.
# 11 Feb 2013 KP
sub _print_with_word {
    my $args = shift;

    if ( ref $args ne q/HASH/ ) {
        croak(
            sprintf q/Usage: %s /,
            ( caller 0 )[$FUNCTION_NAME_POSITION]
        );
    }
    foreach my $required_key (qw/log_date data/) {
        if ( !$args->{$required_key} ) {
            croak(qq/Missing required key '$required_key' in args/);
        }
    }

    my $header = _slurp_file( $CONFIG->{'_'}{'header_file'} );
    my $footer = _slurp_file( $CONFIG->{'_'}{'footer_file'} );

    my @rows = @{ $args->{'data'} };

    my $word   = Win32::OLE->new( 'Word.Application', 'Quit' );
    _debug(q/Created new Word object/);

    my $doc    = $word->Documents->Add();
    _debug(q/Added new document/);

    my $selection = $word->Selection;
    _debug(q/Got Selection instance/);    

    
    my $selection_paragraph_format = $selection->ParagraphFormat;
    _debug(q/Got ParagraphFormat instance for selection/);
    
    $selection_paragraph_format->{'SpaceAfter'} = 0;
    _debug(q/Set paragraph spacing for header/);
    
    $selection->TypeText( { 'Text' => qq/$header\n\n/, } );
    _debug(q/Typing header into selection/);
    
    $selection->BoldRun();
    _debug(q/started bold run/);
    
    $selection_paragraph_format->{'Alignment'} = wdAlignParagraphRight;
    _debug(q/Set date paragraph format to right/);
    
    $selection->TypeText(
        {
            'Text' => Time::Piece->strptime(
                $args->{'log_date'}, q|%m/%d/%Y %H:%M:%S|
              )->strftime(qq/%A %B %d %Y\n\n/)
        }
    );
    _debug(q/Typing date header into selection/);
    
    $selection->BoldRun();
    _debug(q/End bold run/);

    my $range  = $selection->Range;
    _debug(q/Got Range instance from selection/);
    
    my $tables = $doc->Tables;
    _debug(q/Got Tables collection from document/);
    
    my $table  = $tables->Add( $range, scalar @rows, scalar @{ $rows[0] } );
    _debug(q/Added new table to document/);
    
    for my $rownum ( 0 .. $#rows ) {
        my $cols = $rows[$rownum];
        for my $colnum ( 0 .. $#{ $rows[$rownum] } ) {
            my @cellpos    = ( $rownum + 1, $colnum + 1 );
            my $cell       = $table->Cell(@cellpos);
            _debug(qq/Got cell at ($cellpos[0], $cellpos[1]) /);
            
            my $cell_range = $cell->Range;
            _debug(qq/Got Range instance for cell at ($cellpos[0], $cellpos[1])/);
            
            $cell_range->{'Text'} = $cols->[$colnum];
            _debug(qq/Set text of Range for cell at ($cellpos[0], $cellpos[1]) to "$cols->[$colnum]"/);
        }
    }
    my $rows                 = $table->Rows;
    _debug(q/Got Rows collection from table/);
    
    my $first_row            = $rows->First;
    _debug(q/Got first Row object (header row) from Rows collection/);
    
    my $first_row_range      = $rows->First->Range;
    _debug(q/Got Range instance for header row/);
    
    my $first_row_range_font = $first_row_range->Font;
    _debug(q/Got Font instance for header row Range/);
    
    $first_row_range_font->{'Bold'} = 1;
    _debug(q/Set header row Range Font to bold/);
    
    my $first_row_range_paragraph_format = $first_row_range->ParagraphFormat;
    _debug(q/Got ParagraphFormat instance for header row/);
    
    $first_row_range_paragraph_format->{'Alignment'} = wdAlignParagraphCenter;
    _debug(q/Set alignment for table headers to center/);
    
    my $first_row_bottom_border = $first_row->Borders(wdBorderBottom);
    _debug(q/Got Border instance for bottom of header row/);
    
    @{$first_row_bottom_border}{qw/LineStyle LineWidth/} =
      ( wdLineStyleDouble, wdLineWidth100pt );
    _debug(q/Set bottom border of header row to 10 pt double line/);
      
    my $paragraphs            = $doc->Paragraphs;
    _debug(q/Got Paragraphs collection from document/);
    
    my $last_paragraph        = $paragraphs->Last;
    _debug(q/Got last paragraph from document/);
    
    my $last_paragraph_format = $last_paragraph->Format;
    _debug(q/Got Format instance for last paragraph/);
    
    $last_paragraph_format->{'Alignment'}  = wdAlignParagraphLeft;
    _debug(q/Set last paragraph alignment to left/);
    
    $last_paragraph_format->{'SpaceAfter'} = 0;
    _debug(q/Set spacing on last paragraph/);
    
    my $last_paragraph_range = $last_paragraph->Range;
    _debug(q/Got Range instance for last paragraph/);
    
    $last_paragraph_range->InsertAfter( { 'Text' => qq/\n$footer/ } );
    _debug(q/Inserting footer after last paragraph range/);
    
    #$doc->SaveAs( { 'Filename' => Cwd::getcwd . '/test.doc' } );
    
    $doc->PrintOut();
    _debug(q/Printed document/);
    
    $doc->Close( { 'SaveChanges' => wdDoNotSaveChanges } );
    _debug(q/Close document without saving/);
    
    $word->Quit();
    _debug(q/Quit Word/);
    
    return 1;
}