I've put together a new perl module on CPAN called Yote. It directly and automatically binds javascript client objects to perl server objects. The objects are container objects that live in an object database. The objects are lazily loaded as needed and are automatically stored with their contents automatically. The following example works out of the box as long as the Hello package is in the Yote server's perl classpath. The hello count will be preserved in Yote's data store.
Server Side Perl
package Hello;
use base 'Yote::AppRoot';
sub hello {
my( $self, $input ) = @_;
$self->set_hello_count( $self->get_hello_count( 0 ) + 1 );
return "Hello $input, I have said hello ".
$self->get_hello_count() . " times";
}
1;
I recently ran into a bunch of problems where our MPLS provider inadvertently modified the MTU sizes of several of our locations. Unfortunately at about the same time we had swapped out our firewall, so after spending significant time thinking we had weird issues with the new firewall, we finally discovered the actual problem was an incorrect MTU size for those sites.
This wasn't the first time the MTU sizes had been monkeyed with, so I decided to throw something together that might help us identify MTU problems more quickly.
I'd found Network Duplex speed test so, I used much of that for the actual ping packet creation, which referenced Net::Ping code, so I also compared the current version
of that against what was given in the duplex test node. Then I had to figure out how to turn on the don't fragment flags of the packet. Anyway, the results are below.
I had a bunch of music lyrics that I wanted to print and I didn't want to manually drive gedit. I did, however, want to retain the document formatting. I found a hint in Re^2: using Brother QL-570 printer with Perl and also found sample commands in an Ubuntu Community Documentation post for using the Open Office command line interface for batch printing or viewing. The are also posts out there for doing a similar thing with MS-Word.
The following is what I threw together. It does the job for me, YMMV. I needed to print UTF-8 text files, but Open Office will try to print whatever file you give it using the file extension as a guide to the file format. I have also printed .odt files.
I'm currently using the following to run commands on remote systems through ssh. I'd appreciate any comments or improvements.
One specific question is how to capture STDERR and assign it to the remote host it came from. (I haven't spent much time investigating this issue, so there's probably some easy fix I've overlooked.)
The current library supports basic commands, such as takeoff, pitch, roll, yaw, vert speed, and land. All the preprogrammed flight animations are also in place. Navigation data and video are not yet supportedsee the ROADMAP file for future plans.
I spend today reading about how to pipe a mail received by postfix into a perl script.
I read a lot but could hardly find a solution for my setup. So I give one here.
The case
An application must be able to process email coming in from the net and it must be also able
to respond to these emails.
The setup:
The machine is configured to send all emails over an MTA somewhere in the network
The MTA hosts a virtual mail domain for which it forwards all its email to the machine
The machine holds an application written in PERL
A PERL script īs used as delivery agent to process some mails
The tested platform: Linux Ubuntu 12.04 LTS, postfix 2.9.6
The postfix main.cf configuration created by dpkg-reconfigure postfix
myhostname = [host name]
alias_maps = hash:/etc/aliases
alias_database = hash:/etc/aliases
myorigin = /etc/mailname
mydestination = [list for local delivery]
relayhost = [the MTA name for sending emails]
mynetworks = [see posfix documentation]
mailbox_size_limit = [you would rather set it!]
recipient_delimiter = +
inet_interfaces = all
inet_protocols = ipv4
mail_spool_directory = /var/mail
Notice: If you intent to open(OUT ">", $filename); in your PERL script it will fail with a missing privilege error. To avoid this you have to set default_privs = to an other user than nobody in the postfix main.cf. This has impact on the whole postfix setting. I did not analyse it until now. So if you do this, you do it at your own risk.
Enjoy!
K
The best medicine against depression is a cold beer!
Despite an incredible amount of literature on this topic, I could not find a proper solution for this issue. Accordingly I post my one here.
I had to realize a relatively complex web application. This application bases on CGI.pm and mod_perl for performance reasons and supports several languages. I wanted to have one single code for the logic of the application. An additional requirement was be to be able to add languages easily. After reading a lot about solutions involving templates or dictionaries (typically gettext), I figured out using PERL language packages would fulfill most of my requirements. The problem was to load the appropriate language module at application start up time and to allow the user to change the language for example for print outs. Here is the solution I worked out.
First make a set of simple language packages with names like EN.pm, FR.pm, DE.pm. Each of these modules holds hashes with the texts for the application's forms. For this solution to work properly, the hash names must be in lower case. Example for a log in form:
- French in FR.pm: $login{msg1} = "Identifiant";
- German in DE.pm: $login{msg1} = "Benutzername";
- English in EN.pm: $login{msg1} = "User name";
Next use the following at the beginning of each language package to export the content. Example for EN.pm:
This will export all hashes in lower case and avoid for example the EXPORT array. Next you will have to import the correct languages package in your cgi script with a statement like use [Modulename];.
Unfortunaltely you can hardly load modules dynamically and can hardly reference a variable in a module dynamically. Constructs like use $language; or ${language}::login{msg1}; will not work.
Despite lot of posts on this topic, I haven't found a solution to solve this issue. This means so or so I will not be able to load the languages dynamically but will have to manage the supported languages in the code of the application's logic.
My solution bases on a language variable I called syslang. This variable is either set by the calling cgi script or defined by the selected language of the client's browser. I begin my cgi scripts the following way and include a global language variable:
# ----------------------------------------------------------------
+----------------
# Script header
# ----------------------------------------------------------------
+----------------
# Loading perl modules
my $start = time();
use FindBin qw($Bin);
use File::Basename;
use Cwd;
use CGI qw/:standard *table tr td select/;
use CGI::Carp;
use CGI::Session;
use Data::Dumper;
use strict;
# Our global language variable
our $syslang = undef;
Next I add the path to my application or packages to @INC array. My application packages are always in a lib directory. This is also the location of the language packages. For the solution to work the @INC array must be enhanced with a begin block or the script will not compile:
# Notice: this will work with Apache, cheap web-server might be a
+serious issue!
# a) Detect if we are called by the web-server or not
# b) Set the path accordingty
BEGIN {
# Adding application lib path
my $libdir = undef;
if ( not defined($ENV{SERVER_NAME}) ) { $libdir = getcwd; }
else { $libdir = File::Basename::dirname($ENV{SCRIPT_FILENAME}
+); }
# I know.... but sometimes I am lazy!
chdir "$libdir/../lib";
$libdir = getcwd;
if ( not grep(/$libdir/, @INC) ) { push (@INC, $libdir); }
undef $libdir;
}
Now we need to manage the languages. We need to load the package with the correct texts, knowing the user can change the language of the application. Because of mod_perl we need to unload the language modules first and the reload the correct module to force Apache to recompile the script. Here my solution for this:
# Setting the language
# This one is to fool the compiler! Don't ask!
use EN;
# Testing if the language has allready be set or using the one def
+ines by the browser
# frdlang is my cgi language parameter
my $q = new CGI;
if ( $q->param("frdlang") ) { $syslang = uc($q->param("frdlang"));
+ }
elsif ( not $syslang ) { $syslang = uc(substr($ENV{HTTP_ACCEPT_LAN
+GUAGE}, 0, 2)); }
# Unloading language modules to force recompiling under mod_perl
foreach my $lang ( grep(/DE.pm$|FR.pm$|EN.pm$/, keys(%INC)) ) { de
+lete $INC {$lang}; }
# Loading apropriate language module
if ( uc($syslang) =~ /^DE/ ) { require DE; DE->import(); }
elsif ( uc($syslang) =~ /^FR/ ) { require FR; FR->import(); }
elsif ( uc($syslang) =~ /^EN/ ) { require EN; EN->import(); }
Now we might have the issue that some packages return some part of the HTML form, tipically the menus. The language of these parts musst also be changed each time the user switches the language. So we need to reload all the modules impacted. Here my solution for this:
# Unloading the application language related module to force recom
+pile under mod perl
foreach my $module ( grep(/utils.pm$|install.pm$|login.pm$/, keys(
+%INC)) ) { delete $INC{$module}; }
# setting languages for each modules to load
$utils::syslang = $syslang;
$install::syslang = $syslang;
$login::syslang = $syslang;
# Loading language dependent modules
require utils; utils->import();
require install; install->import();
require login; login->import();
# ... your cgi code.
Not sure if this counts as "cool use" but this little thing has become one of my favorite tools over the past few years. Pass any plaintext data through it and emphasize any text you want using regular expressions. Useful for tcpdump, server logs...anything really.
Update: After posting version 1 the problem of overlapping matches has been bugging me so much I've actually found a solution. Instead of using straight regex substitution I now do all the matching first, then apply the colors afterwards. I've tested it quite a bit but it's still experimental.
#!/usr/bin/perl
use strict;
use warnings;
use Term::ANSIColor;
my @rules = @ARGV;
while (my $line = <STDIN>) {
print rewrite($line, @rules);
}
exit;
# Process a single line
sub rewrite {
my $line = shift;
my @rules = @_;
my @marks = ();
# Process each rule and find areas to mark
while (@rules) {
my $regex = shift @rules;
my $color = shift @rules || 'bold yellow';
$color = color('reset').color($color);
while ($line =~ /$regex/ig) {
my $reset = undef;
# Scan match area to find last color
foreach my $i (reverse $-[0] .. $+[0]) {
if (defined $marks[$i]) {
$reset = $marks[$i] unless defined $reset;
$marks[$i] = undef; # Cancel previous color
}
}
# If necessary, keep scanning to beginning of line
unless (defined $reset) {
foreach my $i (reverse 0 .. $-[0]) {
if (defined $marks[$i]) {
$reset = $marks[$i];
last;
}
}
}
# Mark area
$marks[$-[0]] = $color;
$marks[$+[0]] = $reset || color('reset');
}
}
# Apply color codes to the string
foreach my $i (reverse 0 .. $#marks) {
substr($line, $i, 0, $marks[$i]) if defined $marks[$i];
}
return $line;
}
=pod
=head1 NAME
em - console emphasis tool version 2
=head1 DESCRIPTION
em is a command line tool for visually emphasizing text in log files e
+tc. by
colorizing the output matching regular expressions.
=head1 SYNOPSIS
em REGEX1 [COLOR1] [REGEX2 [COLOR2]] ... [REGEXn [COLORn]]
=head1 USAGE
REGEX is any regular expression recognized by Perl. For some shells
this must be enclosed in double quotes ("") to prevent the shell from
interpolating special characters like * or ?.
COLOR is any ANSI color string accepted by Term::ANSIColor, such as
'green' or 'bold red'.
Any number of REGEX-COLOR pairs may be specified. If the number of arg
+uments
is odd (i.e. no COLOR is specified for the last REGEX) em will use 'bo
+ld yellow'.
Overlapping rules are supported. For characters that match multiple ru
+les,
only the last rule will be applied.
=head1 EXAMPLES
In a system log, emphasize the words "error" and "ok":
=over
tail -f /var/log/messages | em error red ok green
=back
In a mail server log, show all email addresses between <> in white, su
+ccesses in green:
=over
tail -f /var/log/maillog | em "(?<=\<)[\w\-\.]+?\@[\w\-\.]+?(?=\>)" "b
+old white" "stored message|delivered ok" "bold green"
=back
In a web server log, show all URIs in yellow:
=over
tail -f /var/log/httpd/access_log | em "(?<=\"get).+?\s"
=back
=head1 BUGS AND LIMITATIONS
Multi-line matching is not implemented.
All regular expressions are matched without case sensitivity.
=head1 AUTHOR
Andreas Lund <floyd@atc.no>
=head1 COPYRIGHT AND LICENSE
Copyright 2009-2013 Andreas Lund <floyd@atc.no>. This program is free
+software;
you may redistribute it and/or modify it under the same terms as Perl
+itself.
=cut
1. I would love for someone to adopt this and put it on CPAN so myself and others can get easy access to it 2. There's one annoying limitation; overlapping matches don't behave the way they should, and I can't find a way to fix it.
Update: There is one other cool way to use this tool, and that's regex testing. Simply type "em" and the regex you want to test. Example: em "0x[0-9a-f]+"
Now input your test strings one by one, and "em" will show you exactly what matches and what doesn't. Hit Ctrl+D (EOF) to exit.
--
Time flies when you don't know what you're doing
As a programmer and teacher of the Perl programming language, I often get destabilizing questions. In one of the last class I gave, while I was talking about hashes, someone asked me "What is it used for? When would I ever need that?" Of course, for me (and you too, probably) hashes are quite practical, but being told that, on the spot, I didn't know what to say, so I talked about the %ENV hash and made an example with it.
Today I found an interesting use for hashes. I wish I would have thought of it during my class but I didn't, so I would like to share it with you for the benefit of newer Perl programmers.
Imagine you have to read a Space Separated Value file or Comma Separated Value (CSV) file. It's easy because the fields are always in the same order. For example:
# firstname lastname age
joe builder 9
bob plumber 66
dora squarepants 10
diego simpson 11
open( $l, "<file" ) || die "Error : $!";
my @lines = <$l>;
close( $l );
foreach my $line ( @lines ) {
# Skipping if the line is empty or a comment
next if ( $line =~ /^\s*$/ );
next if ( $line =~ /^\s*#/ );
my ($firstname, $lastname, $age) = split( /\s+/, $line );
# then do whatever you have to
}
What do you do? Do you change your code with a if statement? Do you alter the file to change the order of the fields and remove the extra fields? No! You use hashes!
Here is the solution:
open( $l, "<file" ) || die "Error : $!";
my @lines = <$l>;
close( $l );
my @keys = split( /\s+/, $lines[0] );
shift( @keys ); # to remove the # as the first field
foreach my $line ( @lines ) {
# Skipping if the line is empty or a comment
next if ( $line =~ /^\s*$/ );
next if ( $line =~ /^\s*#/ );
my %hash;
@hash{ @keys } = split( /\s+/, $line );
# then do whatever you have to
}
Note that the first line in the file is important, it gives you the order of the fields. Even if it's not there when you receive the file, you can easily add it. Note the @hash{ } syntax. This is called a slice. You are slicing the hash using the array form, basically to access a list of element from the hash. The @keys array contains a list of keys in the same order written at the top of the file therefore, doing @hash{ @keys } is like doing @hash{ qw(lastname firstname age gender phone) } or @hash{ 'lastname', 'firstname', 'age', 'gender', 'phone' } except it doesn't matter if the fields in the file are not always in the same order as in the previous file.
The split of the line returns a list so doing this:
The following is an example of nested forks with Parallel::ForkManager, forked DBI calls with DBIx::Connector, and forked WWW::Mechanize::Firefox. This combination allows for easy concurrent unique HTTP sessions with WWW::Mechanize::Firefox on one URL.
MySQL is used here for housing subscription/login data, and a table to store Firefox profile names. The latter is used to avoid a race condition on selecting the Firefox profile to use when constructing $mech objects. Each Firefox profile has been pre-created, and configured with the Mozrepl plugin on a unique TCP/IP port.
The subsequent Perl module contains an example country subroutine which eludes to not-shown encapsulation of the WWW::Mechanize::Firefox and PDF::API2 calls.
Special thanks to Corion, and perlmonks.org chat boxers :)
fork_dbi_mech.pl
#!/usr/bin/perl
use DBIx::Connector;
use Parallel::ForkManager;
use lib './';
use fork_dbi_mech;
use strict;
# I use constant here for limiting nested forks (4*4)
use constant MAXPROCS => 4;
# DBI object constructor with dsn
my $conn = DBIx::Connector->new(
'DBI:mysql:MyDatabase;host=localhost',
'login',
'password')
or die $DBI::errstr;
# fork object constructors
my $fork_cases = new Parallel::ForkManager(MAXPROCS);
my $fork_countries = new Parallel::ForkManager(MAXPROCS);
# example SQL query to suss subs to process
my $subscription = $conn->dbh->selectall_hashref('SELECT customer_id
FROM subscriptions
WHERE active = 1
GROUP BY customer_id', 'customer_id'
);
# Now get each customer login/id, and suss
# their active country subs
foreach $subscription_key (keys %$subscription) {
$sth = $conn->dbh->prepare('SELECT login
FROM customer_info
WHERE id = ?'
);
$sth->execute($subscription_key);
$login = $sth->fetchrow_hashref;
$counties = $conn->dbh->selectall_hashref("SELECT country_id
FROM subscription_info
WHERE customer_id = $subscription_key
AND active = 1",
'country_id'
);
# First fork by customer's country subs
# Then suss each country's cases
foreach $country_key (keys %$countries) {
$fork_countries->start and next;
$sth = $conn->dbh->prepare('SELECT country
FROM country_info
WHERE id = ?
AND active = 1'
);
$sth->execute($country_key);
$results = $sth->fetchrow_hashref;
if ($results->{'country'}) {
$country_name = $results->{'country'};
$sth = $conn->dbh->prepare('SELECT filename, case_no
FROM batch_info
WHERE country LIKE ?
AND customer_id = ?'
);
$sth->execute('%' . $country_name . '%', $subscription_key);
$case = $sth->fetchall_hashref('filename');
# Second fork by customer's cases
# Then call subroutine named after country
foreach $case_no (keys %$case) {
$fork_cases->start and next;
$country_name =~ s/[-|\s]//g;
# Create fork's own DBI object
$conn = DBIx::Connector->new('DBI:mysql:MyDatabase;host=localhost'
+,
'login',
'password')
or die $DBI::errstr;
# Lock the table to avoid race condition
$sth = $conn->dbh->prepare('LOCK TABLE profile_info WRITE');
$sth->execute();
# Suss list of available Firefox profiles
$sth = $conn->dbh->prepare('SELECT * FROM profile_info');
$sth->execute();
# Pick a random hash value
# Delete that value from db
$ff_profile_hash = $sth->fetchall_hashref('id');
delete $_->{id} for values %$ff_profile_hash;
foreach $ff_profile_temp (keys %$ff_profile_hash) {
$ff_profile_hash->{$ff_profile_temp} = $ff_profile_temp;
}
$ff_profile = $ff_profile_hash->{(keys %$ff_profile_hash)[rand key
+s %$ff_profile_hash]};
$sth = $conn->dbh->prepare('DELETE FROM profile_info
WHERE id = ?'
);
$sth->execute($ff_profile);
# Unlock table for next fork
$sth = $conn->dbh->prepare('UNLOCK TABLES');
$sth->execute();
$sth->finish();
# Call country subroutine
{
no strict 'refs';
&$country_name($case->{$case_no}->{'case_no'},
$case_no,
$login->{'login'},
$ff_profile
);
}
# Lock table again and replace Firefox profile
$sth = $conn->dbh->prepare('LOCK TABLE profile_info WRITE');
$sth->execute();
$sth = $conn->dbh->prepare('INSERT INTO profile_info (id)
VALUES (?)'
);
$sth->execute($ff_profile);
$sth = $conn->dbh->prepare('UNLOCK TABLES');
$sth->execute();
$sth->finish();
$fork_cases->finish;
}
$fork_cases->wait_all_children;
}
$fork_countries->finish;
}
$fork_countries->wait_all_children;
}
1;
#!/usr/bin/perl
package fork_dbi_mech;
require Exporter;
use DBIx::Connector;
use Error qw(:try);
use PDF::API2;
use String::Random;
use Switch;
use WWW::Mechanize::Firefox;
use strict;
our @ISA = qw(Exporter);
our @EXPORT = qw(
USA
UK
JAPAN
);
# I use $rand to pad cache files for $mech->content, etc.
my $rand = new String::Random;
sub USA {
$args_case = $_[0];
$args_filename = $_[1];
$args_login = $_[2];
$ff_profile = $_[3];
# I based my Mozrepl ports off the default 4242 * 10
# Ports are the sum of of this and the Firefox profile
$ff_port = 42420 + $ff_profile;
# Now construct the unique $mech object
$m = WWW::Mechanize::Firefox->new(
launch => ['firefox',
'-P',
$ff_profile,
'-no-remote',
'-width',
'1024',
'-height',
'768'],
repl => "localhost:$ff_port",
bufsize => 10_000_000,
tab => 'current',
autoclose => 1
);
$url = 'http://usa.example.com';
# Try a $mech->get($url);
&tryMech($args_filename,
$args_login,
$args_case,
'URL',
undef,
$url
);
if ($mech_status == 1) {
&tryMech($args_filename,
$args_login,
$args_case,
'field',
'CaseField',
$args_case
);
if ($mech_status == 1) {
&tryMech($args_filename,
$args_login,
$args_case,
'click',
'Search'
);
if ($mech_status == 1) {
&makePDF($args_filename,
$args_login,
$args_case
);
}
}
}
undef $m;
sleep(1);
}
1;
