PerlSnips

From Custard
Jump to: navigation, search

Perl Snips

Contents


Plack/Starman/NGINx

Prerequisites

  • sudo apt-get install nginx
  • sudo apt-get install build-essential curl
  • sudo cpanm Starman
  • sudo cpanm Task::Plack
  • sudo apt-get install libdancer-perl

Run the App under Starman

  • sudo plackup -s Starman -p 10080 -E deployment --workers=10 -a DancerAPP/bin/dance.pl

Configure NGINx

server {
    server_name dance.org
    listen 80;

    location / {
        proxy_pass        http://localhost:10080;
        proxy_set_header  X-Real-IP  $remote_addr;
    }
}

Selenium Web Driver

  • Run the Selenium web-driver jar.
#!/usr/bin/perl -w

use strict;
use warnings;

use Selenium::Remote::Driver;

my $driver = new Selenium::Remote::Driver(
    remote_server_addr => '10.10.10.69',
);
$driver->get('https://app.example.com');
print $driver->get_title();
my $email = $driver->find_element('emailAddress','id');
$email->send_keys('test@example.com');
my $pass = $driver->find_element('password','id');
$pass->send_keys('Password-123');

# Submit login
$driver->find_element('submit','id')->click();                                                                                     
$driver->quit();

Moose Default Types

eg.

has 'dao'           => ( is => 'rw', isa => 'Object',   builder => '_build_dao',      lazy => 1, );
has 'articles'      => ( is => 'rw', isa => 'ArrayRef', builder => '_build_articles', lazy => 1, );
has 'article'       => ( is => 'rw', isa => 'HashRef',  builder => '_build_article',  lazy => 1, );
 Any
  Item
      Bool
      Maybe[`a]
      Undef
      Defined
          Value
              Str
                  Num
                      Int
                  ClassName
                  RoleName
          Ref
              ScalarRef[`a]
              ArrayRef[`a]
              HashRef[`a]
              CodeRef
              RegexpRef
              GlobRef
              FileHandle
              Object


Aspect oriented programming (AOP)

Simple function call logger

before

use Aspect;

before {
    warn( $_->sub_name()."\n" );
} call qr/^main::.*/;

after

  after {
      warn( $_->sub_name . "\n" );
      $_->return_value(undef);
  } call qr/^main::poop/;

around

  around {
      my @start   = Time::HiRes::gettimeofday();
      $_->proceed;
      my @stop    = Time::HiRes::gettimeofday();
      my $elapsed = Time::HiRes::tv_interval( \@start, \@stop );
      print "main::poop executed in $elapsed seconds\n";
  } call 'main::poop';


Moose, Mouse, Moo or Mo

Dancer

Dancer is a micro framework similar to Ruby's Sinatra.

Basic example

#!/usr/bin/perl

use strict;
use warnings;

use Dancer;

get '/' => sub {
    return 'Hello World!';
};

start;

Dancer using Plack

bin/dancetest.pl

#!/usr/bin/perl

use Plack::Builder;
use Dancer ':syntax';
use Dancer::Handler;
use FindBin;
use lib "$FindBin::Bin/../lib";
use Cwd qw/realpath/;

# plackup bin/dancetest.pl

my $app = sub {
    my $env = shift;
    my $appdir=realpath( "$FindBin::Bin/..");

    setting     appdir => $appdir;
    load_app    "DanceTest";

    Dancer::Config::setting('appdir',$appdir);
    Dancer::Config::load();

    set views => $appdir.'/views';

    Dancer::App->set_running_app("DanceTest");
    Dancer::Handler->init_request_headers($env);
    my $req = Dancer::Request->new(env => $env);

        print "environment:".config->{environment}."\n"; #development
        print "log:".config->{log}."\n"; #value from development environment

    Dancer->dance($req);
};

builder {
    mount "/dancetest" => $app;
};

lib/DanceTest.pm

package DanceTest;

use 5.006;
use strict;
use warnings FATAL => 'all';

our $VERSION = '0.01';

use Dancer;

=head1 ROUTES

=cut

get '/' => sub {                                                                                                                                  template 'index.tt';
};                                                                                                                                      
get '/hello/:name' => sub {
    my $data = {
        hello =>  param('name')
    };
    return to_xml( $data );
};

post '/upload' => sub {
    my $file=upload( 'image' );
    forward '/display', { uploaded => $file }
};

get '/display' => sub {
    return 'Thanks for your file: '.param('uploaded')->filename;
};

"All your base are belong to us!";

config.yml

template: template_toolkit
engines:
    template_toolkit:
        encoding:  'utf8'
        start_tag: '[%'
        stop_tag: '%]'
        RELATIVE : 1
        COMPILE_EXT: '.ttc'

Plack psgi

  • cpanm Plack

hello_world.psgi

my $app = sub {
    my $env = shift;
    my $body = "Hello World";
    my $headers;
    my $status;
    return [ $status, $headers, $body ];
};
  • plackup hello_world.psgi

Configuring Cisco Switches

Using Net::Telnet::Cisco

#!/usr/bin/perl

package Main;
use strict;
use warnings;

use Net::Telnet::Cisco;
use Moose;
use IO::File;

has 'cisco' => (is => 'rw');

sub run {
  my $self = shift;
  my $ip   = shift || '';
  my $passwd=shift || 'SecretPassword';

  if ($ip=~/(^\d+\.\d+\.\d+\.\d+$)/) {
    print( "Connecting $ip\n" );
    $self->cisco( Net::Telnet::Cisco->new( Host => $ip ) );
    $self->cisco->login( Password => $passwd );
    $self->cisco->enable( Password => $passwd );
#   $self->cisco->cmd( 'config terminal' );
#   $self->cisco->cmd( 'enable password OldStyleSecretPassword' );
#   $self->cisco->cmd( 'enable secret SecretPassword' );
#   $self->cisco->cmd( 'exit' );
#   $self->cisco->cmd( 'write' );

    my $config = join('',$self->cisco->cmd( 'show running-config' ));
    $self->save( $config );
  } else {
    die( "Invalid IPv4 address: $ip\n" );
  }
}

sub save {
  my $self   = shift;
  my $config = shift;
  print $config."\n";
  my $hostname = ($config=~/^hostname ([^\n! ]+)/m)[0];
  print "Writing $hostname\n";
  if (my $file = IO::File->new( ">$hostname" )) {
    $file->print( $config );
    $file->close();
  } else {
    die( "Cannot open $hostname for writing. $@" );
  }

}

Main->new->run( $ARGV[0], $ARGV[1] );

Install CPANminus

Create a new module for CPAN

We'll use the Module::Starter module (http://search.cpan.org/~xsawyerx/Module-Starter-1.57/)

Install the Module::Starter module

# perl -MCPAN -e"install Module::Starter"
CPAN: Storable loaded ok (v2.22)
Going to read '/Users/jamesb/.cpan/Metadata'
  Database was generated on Wed, 15 Jun 2011 01:39:10 GMT
CPAN: Module::CoreList loaded ok (v2.43)
Module::Starter is up to date (1.57).

Create your module

$ module-starter --module=Ham::DXSpider --author="Bruce James" --email=custard@cpan.org
Added to MANIFEST: Changes
Added to MANIFEST: ignore.txt
Added to MANIFEST: lib/Ham/DXSpider.pm
Added to MANIFEST: Makefile.PL
Added to MANIFEST: MANIFEST
Added to MANIFEST: README
Added to MANIFEST: t/00-load.t
Added to MANIFEST: t/boilerplate.t
Added to MANIFEST: t/manifest.t
Added to MANIFEST: t/pod-coverage.t
Added to MANIFEST: t/pod.t
Created starter directories and files

Head off to PAUSE to upload it

http://pause.perl.org/pause/query

Exclude certain categories from Log4Perl log entries

Say you have a tree of classes and want most to get logged to one appender but one sub class logged to another. If you set up two loggers one for Main and one for Main::Sub then the Main logger will also catch the Main::Sub logs. There doesn't appear to be an easier way to do this but you can set up a category filter in log4perl to exclude classes containing the name of the Sub class.

log4perl.logger.MainCategoryClass = DEBUG, MainCategory

# Create a filter to filter out DataBridge logs from the Dynamite log
log4perl.filter.OmitSubCategory = sub { my %p=@_; $p{log4p_category}!~/SubCategory/ }

...
log4perl.appender.MainCategory.Filter         = OmitSubCategory

So that stuff logged under MainCategoryClass gets logged but not MainCategoryClass::SubCategory::*

Debug output of regular expressions

perl -Mre=debugcolor -e 'q/aaa/ =~ /a/'

Set DBI debug on

Useful for debugging Class::DBI or DBIx::Class implementations.

export DBI_TRACE=1


Catalyst

Installation

  • install the CPAN modules
 perl -MCPAN -einstall Catalyst
 perl -MCPAN -einstall Catalyst::Devel

This will install the Catalyst and Catalyst::Devel modules and all the dependencies.

It is also recommended to install DBIx::Class and possibly Moose.

  • Create your application
brucej@pandora~/projects $ ./cpan/scripts/catalyst.pl
Usage:
    catalyst.pl [options] application-name

    'catalyst.pl' creates a skeleton for a new application, and allows you
    to upgrade the skeleton of your old application.

     Options:
       -force      don't create a .new file where a file to be created exists
       -help       display this help and exit
       -makefile   only update Makefile.PL
       -scripts    only update helper scripts
       -short      use short names, M/V/C instead of Model/View/Controller.

     application-name must be a valid Perl module name and can include "::",
     which will be converted to '-' in the project name.

     Examples:
        catalyst.pl My::App
        catalyst.pl MyApp

     To upgrade your app to a new version of Catalyst:
        catalyst.pl -force -scripts MyApp

Run the test server

cd MyApp
perl scripts/myapp_server.pl

Quick soap server

Creates a class called Simple::SOAP::Server, which contains a method 'alive' which can be called remotely. The SOAP handler is the class itself.

package Simple::SOAP::Server;
use strict;
use warnings;

# CPAN Modules
use SOAP::Lite;
use SOAP::Transport::HTTP;

sub new {
        my $class=shift;
        my $this={};
        bless( $this, $class );
        my $host=shift ||| '';
        my $port=shift ||| '8000';

        warn( "Starting SOAP Server on $host:$port...\n" );
        # Configure the server daemon
        my $server = new SOAP::Transport::HTTP::Daemon( LocalAddr =>    $host,
                                                        LocalPort =>    $port,
                                                        dispatch_to =>  $class
        );
        # Notes.
        # uri doesn't appear to be necessary in the server, but is in the client
        # dispatch_to must match class given in the URI
        # ie. uri='http://Server/Simple/SOAP/Server' class=Simple::SOAP::Server

        $server->handle();

        return $this;
}

sub alive {
        my $this=shift;
        return "I'm alive!";
}

Quick soap client

use SOAP::Lite;
use SOAP::Transport::HTTP;

my $host='Server';
my $port='8000';
my $client = new SOAP::Lite(    uri => 'http://Server/Simple/SOAP/Server',
                                proxy => "http://$host:$port/"
);
if ($client) {
	my $result =  $client->alive();
	if ($result) {
          		print $result->result()."\n";
      } else {
          	 	warn( "The SOAP server gave no response().\n" );
      }
} else {
   	warn( "There is a problem connecting to the remote process.\n" );
}

Hash slices

my %hash;
my @keys = ( 'one','two','three' );
my @values = ( 1,2,3 );

# Initialise the hash from the keys and values arrays.
@hash{ @keys }=@values;

# Retrieve the values of elements 'one' and 'three' into an array.
@keys = ( 'one','three' );
my @array = @hash{ @keys };

Setting up a mod_perl2 handler in apache2 httpd.conf

Generic Mod Perl App

	# Perl Module Handler.
	#
	PerlOptions +GlobalRequest
	PerlSwitches -I/usr/local/lib
	PerlModule Apache2;
	PerlModule WEB::AppHandler
	<Location /webapp>
		# The web app, or web service handler
		SetHandler modperl
		PerlResponseHandler WEB::AppHandler
	</Location>

Catalyst app

    PerlSwitches -I/path/to/mod_perl/my_app/lib
    PerlModule MyCatalystApp
    
    <Location />
        SetHandler  modperl
        PerlResponseHandler  MyCatalystApp
    </Location>

Date & Time parsing with DateTime

Parse an ISO8601 datetime string

Like: "2008-01-28T12:18:00Z"

 
  my $datetime = DateTime::Format::ISO8601->parse_datetime( "2008-01-28T12:18:00Z" );

Parse MySQL datetime


  my $datetime = DateTime::Format::MySQL->parse_datetime( '' );

Multidimensional hashes

This feature was introduced in Perl 4 as a means to emulate multidimensional arrays. It is probably better to use a hash of hashes nowadays although this sometimes still has its uses. For instance with tied hashes to BDB tables.

Emulate a multidimensional hash by specifying more than one key separated by commas between the curly braces. These keys will be joined together using the value of $; (default 0x1C ) as a separator. eg.

    $message{ $key, $locale } = $message_string;
Personal tools