 Register |
| Unregistered users click here to register registered users can post their website here |
 Science Humor: |
God doesn't play dice.
-- Albert Einstein
|
| Chuck Norris Humor: |
chuck norris can squeeze orange juice from a banana
|
|
 |
| Passing information between PHP and Perl - |
|---|
// description of your code here
apache_note('name', 'Fredrik Ekengren');
// Call perl script
virtual("/perl/some_script.pl");
$result = apache_note("resultdata");
?>
#!/usr/bin/perl
#some stuff...
# Get Apache request object
my $r = Apache->request()->main();
# Get passed data
my $name = $r->notes('name');
# some processing
# Pass result back to PHP
$r->notes('resultdata', $result);
|
| Send Voice phone call via voice gateway at www.smsmatrix.com - |
|---|
Send voice phone call via voice gateway at www.smsmatrix.com - voice gateway.
use LWP::UserAgent;
use HTTP::Request::Common;
# The voice file provided must be in mp3 or wave format.
# It will be converted to: 16Bit 8kHz mono wave format.
my $ua = LWP::UserAgent->new();
my $res = $ua->request
(
POST 'http://www.smsmatrix.com/matrix_voice',
Content_Type =>'form-data',
Content =>[ username =>'user@hotmail.com',
password =>'pass8988',
phone =>'12502771720', ## comma delimited list
voicefile =>['/tmp/november_sale.wav'],
response=>1, ## optional
callerid =>'16307791722' ## optional
]
);
if ($res->is_error) { die "HTTP Error\n"; }
print "Matrix API Response1: " . $res->content . "\n\n";
|
| send sms in Perl via sms gateway www.smsmatrix.com - |
|---|
Send SMS via SMS Gateway provided by www.smsmatrix.com
use LWP::UserAgent;
use HTTP::Request::Common;
my $ua = LWP::UserAgent->new();
my $res = $ua->request
(
POST 'http://www.smsmatrix.com/matrix',
Content_Type =>'application/x-www-form-urlencoded',
Content =>[ 'username' =>'user888@yahoo.ca',
'password' =>'pass7782',
'callerid' =>'12501231233', # optional (for 2-way sms)
'phone' =>'12506063167',
'txt' =>'this is a test' ]
);
if ($res->is_error) { die "HTTP Error\n"; }
print "Matrix API Response: " . $res->content . "\n\n";
|
| Perl: Checking that your modified files compile - |
|---|
After making some changes, before committing, run this to check that no changes have caused your perl app to not compile
git status | grep modified | awk '{system("perl -c "$3)}'
|
| Calculate Latitude and Longitude from rate Center V&H in Perl - |
|---|
ZIPCodeWorld.com provides this function to calculate the latitude and longitude coordinates from Vertical and Horizontal (V&H) coordinates in Perl. V&H's are used to identify locations and hence relative distances between network elements and between rate centers listed in AreaCodeWorld(TM) North American Area Code Database Subscription which includes NPA (area code), NXX (exchange), country, state, county, latitude, longitude, etc.
use Math::Trig;
#my ($lat, $lon) = vh2latlong(5079,1444);
sub vh2latlong {
my $v = 0;
my $h = 0;
($v, $h) = @_;
my $m_pi = 3.14159265358979323846;
my $transv = 6363.235;
my $transh = 2250.7;
my $rotc = 0.23179040;
my $rots = 0.97276575;
my $radius = 12481.103;
my $ex = 0.40426992;
my $ey = 0.68210848;
my $ez = 0.60933887;
my $wx = 0.65517646;
my $wy = 0.37733790;
my $wz = 0.65449210;
my $px = -0.555977821730048699;
my $py = -0.345728488161089920;
my $pz = 0.755883902605524030;
my $gx = 0.216507961908834992;
my $gy = -0.134633014879368199;
my $a = 0.151646645621077297;
my $q = -0.294355056616412800;
my $q2 = 0.0866448993556515751;
my @bi = ( 1.00567724920722457, -0.00344230425560210245, 0.000713971534527667990, -0.0000777240053499279217, 0.00000673180367053244284, -0.000000742595338885741395, 0.0000000905058919926194134 );
my $x = 0;
my $y = 0;
my $z = 0;
my $delta =0;
my $t1 = ($v - $transv) / $radius;
my $t2 = ($h - $transh) / $radius;
my $vhat = $rotc * $t2 - $rots * $t1;
my $hhat = $rots * $t2 + $rotc * $t1;
my $e = cos(sqrt($vhat * $vhat + $hhat * $hhat));
my $w = cos(sqrt($vhat * $vhat + ($hhat - 0.4) * ($hhat - 0.4)));
my $fx = $ey * $w - $wy * $e;
my $fy = $ex * $w - $wx * $e;
my $b = $fx * $gx + $fy * $gy;
my $c = $fx * $fx + $fy * $fy - $q2;
my $disc = $b * $b - $a * $c;
if ($disc == 0.0) {
$z = $b / $a;
$x = ($gx * $z - $fx) / $q;
$y = ($fy - $gy * $z) / $q;
} else {
$delta = sqrt($disc);
$z = ($b + $delta)/$a;
$x = ($gx * $z - $fx) / $q;
$y = ($fy - $gy * $z) / $q;
if ( $vhat * ( $px * $x + $py * $y + $pz * $z) <0 ) {
$z = ($b - $delta) / $a;
$x = ($gx * $z - $fx) / $q;
$y = ($fy - $gy * $z) / $q;
};
};
my $lat = asin($z);
my $lat2 = $lat * $lat;
my $earthlat = 0;
for (my $i=6; $i>=0 ; $i--) {
$earthlat = ($earthlat + $bi[$i]) * ($i? $lat2 : $lat);
};
$earthlat *= 180/$m_pi;
my $lon = atan2($x, $y) * 180 / $m_pi;
my $earthlon = $lon + 52.0000000000000000;
return ($earthlat, $earthlon);
};
|
| Installing CPAN Modules to Debian - |
|---|
// To fully build CPAN modules into debian in one step use the following wrapper.
dh-make-perl --build --cpan
|
| Distance Calculation using Latitude and Longitude in Perl - |
|---|
ZIPCodeWorld.com provides this routine to calculate the distance between two points (given the latitude/longitude of those points) in Perl. It is being used to calculate distance between two points lat1, long1 and lat2, long2 and uses radius of earth in kilometers or miles as an argurments using our ZIPCodeWorld(TM) and PostalCodeWorld(TM) products which offer the United States ZIP codes, Canadian Postal Codes, Mexican Postal Codes and North American Area Codes database subscription and solution services.
$pi = atan2(1,1) * 4;
sub distance {
my ($lat1, $lon1, $lat2, $lon2, $unit) = @_;
my $theta = $lon1 - $lon2;
my $dist = sin(deg2rad($lat1)) * sin(deg2rad($lat2)) + cos(deg2rad($lat1)) * cos(deg2rad($lat2)) * cos(deg2rad($theta));
$dist = acos($dist);
$dist = rad2deg($dist);
$dist = $dist * 60 * 1.1515;
if ($unit eq "K") {
$dist = $dist * 1.609344;
} elsif ($unit eq "N") {
$dist = $dist * 0.8684;
}
return ($dist);
}
#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
#::: This function get the arccos function using arctan function :::
#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
sub acos {
my ($rad) = @_;
my $ret = atan2(sqrt(1 - $rad**2), $rad);
return $ret;
}
#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
#::: This function converts decimal degrees to radians :::
#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
sub deg2rad {
my ($deg) = @_;
return ($deg * $pi / 180);
}
#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
#::: This function converts radians to decimal degrees :::
#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
sub rad2deg {
my ($rad) = @_;
return ($rad * 180 / $pi);
}
print distance(32.9697, -96.80322, 29.46786, -98.53506, "M") . " Miles\n";
print distance(32.9697, -96.80322, 29.46786, -98.53506, "K") . " Kilometers\n";
print distance(32.9697, -96.80322, 29.46786, -98.53506, "N") . " Nautical Miles\n";
|
| Create shortcuts to PuTTY sessions... - |
|---|
I developed this under Linux, but have adapted it to work with Strawberry Perl.
I make a folder:
%USERPROFILE%\Start Menu\Programs\sessions
And run this in there.
#!/usr/bin/perl
#
# Create a Windows shortcut to each session stored in PuTTY
#
use warnings;
use strict;
use Win32::TieRegistry( Delimiter =>'/' );
my $sessions_key = "HKEY_CURRENT_USER/Software/SimonTatham/PuTTY/Sessions";
my $sessions = $Registry->{$sessions_key}
or die "$0: can't open $sessions_key: $^E\n";
for my $session ( sort keys %$sessions ) {
$session =~ s{/$}{};
$session =~ s{%20}{ }g;
my $file;
if ( $session =~ /^prod / ) {
mkdir "prod" if ! -d "prod";
$file = "prod/$session.lnk";
}
elsif ( $session =~ /^dev / ) {
mkdir "dev" if ! -d "dev";
$file = "dev/$session.lnk";
}
elsif ( $session =~ /^uat / ) {
mkdir "uat" if ! -d "uat";
$file = "uat/$session.lnk";
}
else {
mkdir "other" if ! -d "other";
$file = "other/$session.lnk";
}
open (my $file_fh, '>', $file) || die "Can't write to '$file': $!\n";
for my $byte (
0x4c, 0x00, 0x00, 0x00, 0x01, 0x14, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x46, 0xb3, 0x00, 0x00, 0x00,
0x20, 0x00, 0x00, 0x00, 0xf2, 0x2d, 0x32, 0x8d, 0x14, 0x35, 0xca, 0x01,
0xdb, 0xa7, 0xf2, 0xca, 0x38, 0xab, 0xca, 0x01, 0x00, 0xc8, 0xd2, 0x90,
0x53, 0x8a, 0xc7, 0x01, 0x00, 0xf0, 0x06, 0x00, 0x00, 0x00, 0x00, 0x00,
0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0xdb, 0x00, 0x14, 0x00, 0x1f, 0x50, 0xe0, 0x4f,
0xd0, 0x20, 0xea, 0x3a, 0x69, 0x10, 0xa2, 0xd8, 0x08, 0x00, 0x2b, 0x30,
0x30, 0x9d, 0x19, 0x00, 0x2f, 0x44, 0x3a, 0x5c, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x34, 0x00, 0x31, 0x00, 0x00, 0x00, 0x00, 0x00, 0x49,
0x3c, 0x9a, 0x92, 0x10, 0x00, 0x41, 0x70, 0x70, 0x73, 0x00, 0x00, 0x20,
0x00, 0x03, 0x00, 0x04, 0x00, 0xef, 0xbe, 0x2e, 0x3b, 0x9b, 0x42, 0x4f,
0x3c, 0xea, 0x6c, 0x14, 0x00, 0x00, 0x00, 0x41, 0x00, 0x70, 0x00, 0x70,
0x00, 0x73, 0x00, 0x00, 0x00, 0x14, 0x00, 0x36, 0x00, 0x31, 0x00, 0x00,
0x00, 0x00, 0x00, 0x39, 0x3b, 0x98, 0x63, 0x10, 0x00, 0x50, 0x75, 0x54,
0x54, 0x59, 0x00, 0x22, 0x00, 0x03, 0x00, 0x04, 0x00, 0xef, 0xbe, 0x2e,
0x3b, 0xda, 0x42, 0x4f, 0x3c, 0x13, 0x72, 0x14, 0x00, 0x00, 0x00, 0x50,
0x00, 0x75, 0x00, 0x54, 0x00, 0x54, 0x00, 0x59, 0x00, 0x00, 0x00, 0x14,
0x00, 0x42, 0x00, 0x32, 0x00, 0x00, 0xf0, 0x06, 0x00, 0x9d, 0x36, 0x66,
0x5d, 0x20, 0x00, 0x70, 0x75, 0x74, 0x74, 0x79, 0x2e, 0x65, 0x78, 0x65,
0x00, 0x2a, 0x00, 0x03, 0x00, 0x04, 0x00, 0xef, 0xbe, 0x2e, 0x3b, 0xda,
0x42, 0x4f, 0x3c, 0x22, 0x74, 0x14, 0x00, 0x00, 0x00, 0x70, 0x00, 0x75,
0x00, 0x74, 0x00, 0x74, 0x00, 0x79, 0x00, 0x2e, 0x00, 0x65, 0x00, 0x78,
0x00, 0x65, 0x00, 0x00, 0x00, 0x18, 0x00, 0x00, 0x00, 0x4a, 0x00, 0x00,
0x00, 0x1c, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x1c, 0x00, 0x00,
0x00, 0x31, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x49, 0x00, 0x00,
0x00, 0x15, 0x00, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0xbb, 0x36, 0x59,
0xcc, 0x10, 0x00, 0x00, 0x00, 0x44, 0x41, 0x54, 0x41, 0x00, 0x44, 0x3a,
0x5c, 0x41, 0x70, 0x70, 0x73, 0x5c, 0x50, 0x75, 0x54, 0x54, 0x59, 0x5c,
0x70, 0x75, 0x74, 0x74, 0x79, 0x2e, 0x65, 0x78, 0x65, 0x00, 0x00, 0x0d,
0x00, 0x44, 0x00, 0x3a, 0x00, 0x5c, 0x00, 0x41, 0x00, 0x70, 0x00, 0x70,
0x00, 0x73, 0x00, 0x5c, 0x00, 0x50, 0x00, 0x75, 0x00, 0x54, 0x00, 0x54,
0x00, 0x59, 0x00, 0x2b, 0x00, 0x2d, 0x00, 0x6c, 0x00, 0x6f, 0x00, 0x61,
0x00, 0x64, 0x00, 0x20, 0x00, 0x22, 0x00,
) {
printf $file_fh "%c", $byte;
}
my @string = split(//, $session);
print $file_fh join "\0", @string;
for my $byte ( 0x00, 0x22, 0x00, 0x00 ) {
printf $file_fh "%c", $byte;
}
close $file_fh;
}
Running it under Linux I exported the registry keys with:
regedit.exe /e sessions.reg HKEY_CURRENT_USER\Software\SimonTatham\PuTTY\Sessions
then used this as the start of the program:
my $file = 'sessions.reg';
my @sessions;
open (my $file_fh, $file) || die "Can't read '$file': $!\n";
while (defined (my $line = <$file_fh>)) {
#
next if $line !~ /\[/;
$line =~ s/\0//g;
$line =~ s/%20/ /g;
$line =~ s{/}{-}g;
# print $line;
if ( $line =~ /\[HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions\\(.*)\]/ ) {
push @sessions, $1;
}
}
close $file_fh;
for my $session ( @sessions ) {
|
| Threads to create a server and client application in one using Threads to run them - |
|---|
// Threads to create a server and client application in one using Threads to run them
use warnings;
use strict;
use Frontier::Daemon;
use Frontier::Client;
use threads;
use threads::shared;
my ($nr, %threads);
my $C = {};
share($C);
print "Starting Server\/ Client\n";
&Start(qw[Server Client]);
sleep;
sub Start
{
my @subs = @_;
foreach my $sub (@subs)
{
$C->{$sub} = '1';
$nr++;
$threads{$nr} = threads->new(\&{$sub});
sleep 1;
}
}
sub Test
{
my $time = &Timer();
$C->{'ClientCounter'}++;
my $Result = '#' . $C->{'ClientCounter'} . ' ' . $time . ': You\'re an asshole';
return($Result);
}
sub Timer
{
my ($Second, $Minute, $Hour, $Month, $Year, $WeekDay) = localtime(time);
my $Minutes = $Minute;
if (length($Minute) == 1) {$Minutes = '0' . $Minute}
return("[" . $Hour . ":" . $Minutes . ":" . $Second . "]");
}
sub Client
{
while ($C->{'Client'} eq '1')
{
my $server = Frontier::Client->new( 'url' =>'http://127.0.0.1:1337/RPC2');
my $Result = $server->call('sample.test');
print 'Client->' . $Result . "\n";
}
}
sub Server
{
while ($C->{'Server'} eq '1')
{
my $methods = {'sample.test' =>\&Test};
Frontier::Daemon->new(LocalPort =>1337, methods =>$methods) or die "Couldn't start HTTP server: $!";
}
}
|
| Tiny Perl IRC Bot - |
|---|
// Another IRC Bot written in Perl - Here for my reference, and anyone interested. Most parts of the bot are broken into subroutines to make reading and managing the code easier. So far it just ops and voices an admin. This is my first Perl project to help learn it. The bot.conf looks like
// server=localhost
// botnick=blowfish
// botuser=blowfish
// botname=Blowfish Bot
// botchan=#geeksware
// botadmin=serts
// bothost=.my.ip.or.host|another.ip.or.host|.and.another.example.com
// The bothost can contain all or just some of the wanted hostname as it's all regexp. This means you can add others by appending "|"
#!/usr/bin/perl -w
use strict;
use IO::Socket;
my $conf = "bot.conf";
our $server = "irc.geeksware.net";
our $botnick = "bot";
our $botuser = "bot";
our $botname = "bot";
our $botchan = "#geeksware";
our $botadmin = "serts";
our $bothost = ".geeksware.net";
our $irc;
sub ircsend($)
{
use vars qw($irc);
my $string = shift;
print $irc $string . "\r\n";
}
sub ircmsg($$)
{
my @string = @_;
ircsend("PRIVMSG " . $string[0] . " :" . $string[1]);
}
sub ircnotice($$)
{
my @string = @_;
ircsend("NOTICE " . $string[0] . " :" . $string[1]);
}
sub trim($)
{
my $string = shift;
$string =~ s/^\s+//;
$string =~ s/\s+$//;
return $string;
}
sub botjoin
{
use vars qw($server $botnick $botuser $botname $botchan $botadmin $bothost);
my $usernick = $_[0];
my $username = $_[1];
my $userhost = $_[2];
if ($userhost =~ /$bothost/) {
ircsend("MODE " . $botchan . " +o " . $usernick);
}
}
sub botcmd
{
use vars qw($server $botnick $botuser $botname $botchan $botadmin $bothost);
my $usernick = $_[0];
my $username = $_[1];
my $userhost = $_[2];
my $cmd = $_[3];
for ($cmd) {
if ($cmd eq "uptime") {
my $up = `uptime`;
chomp($up);
ircmsg($botchan, $usernick . ", " . $up); }
elsif ($cmd eq "op") {
if ($userhost !~ /$bothost/) { ircnotice($usernick, "You are not an admin."); }
else { ircsend("MODE " . $botchan . " +o " . $usernick); } }
elsif ($cmd eq "voice") {
if ($userhost !~ /$bothost/) { ircnotice($usernick, "You are not an admin."); }
else { ircsend("MODE " . $botchan . " +v " . $usernick); } }
}
}
sub logmein {
use vars qw($server $irc $botnick $botuser $botname $botchan);
print "Connecting to " . $server . ":6667\n";
our $irc = IO::Socket::INET->new(
PeerAddr =>$server,
PeerPort =>6667,
Proto =>'tcp'
) or die "Could not connect to " . $server . "\n";
print "Connected!\n";
print $irc "USER " . $botuser . " " . $botuser . " blah blah :" . $botname . "\r\n";
print $irc "NICK " . $botnick . "\n";
while (<$irc>) {
for (trim($_)) {
if (/^PING (.+)$/i) { ircsend("PONG $1"); }
elsif (/^:(.+)!(.+)\@(.+) PRIVMSG $botnick :join$/i) {
ircsend("NOTICE " . $1 . " :Joining " . $botchan);
ircsend("JOIN :" . $botchan); }
elsif (/^:(.+) 376/) { ircsend("JOIN :" . $botchan); }
elsif (/^:(.+)!(.+)\@(.+) PRIVMSG $botchan :$botnick,\s+?(.+)$/) { botcmd($1,$2,$3,$4); }
elsif (/^:(.+)!(.+)\@(.+) JOIN :$botchan$/) { botjoin($1,$2,$3); }
else { print $_ . "\n"; }
}
}
close($irc);
}
sub filecheck {
use vars qw($server $botnick $botuser $botname $botchan $botadmin $bothost);
my $f = shift;
open(CONF, $f);
while () {
chomp;
next if $_ eq '';
my(@word) = split(/=/,$_);
if ($word[0] eq "server") {
our $server = $word[1];
} elsif ($word[0] eq "botnick") {
our $botnick = $word[1];
} elsif ($word[0] eq "botuser") {
our $botuser = $word[1];
} elsif ($word[0] eq "botname") {
our $botname = $word[1];
} elsif ($word[0] eq "botchan") {
our $botchan = $word[1];
} elsif ($word[0] eq "botadmin") {
our $bothost = $word[1];
} elsif ($word[0] eq "bothost") {
our $bothost = $word[1];
}
}
close(CONF);
logmein();
}
if (not -e $conf) {
die "Could not find '" . $conf . "'\n";
} else {
filecheck($conf);
}
|
|
|
Jobs:
