Addtoblog
on Jan 19, 2008 at 08:24
|
0 replies
|
by Onur
|
Add your new entry to your blog in blogger with your favorite editor. This program simply using WWW::Mechanize. Default editor is defined with $editor. You can change default editor with --editor argument or $editor variable. You can define $usename and $password for always using. If you dont want to do this you must be start program with --usename and --password arguments.
Also you need SSLeay module.
Onur noted that the script does not work anymore as of 20100618.
#!/usr/bin/perl
######################################################################
+###
# Addtoblog 0.1
+ #
# Add your new entry to your blog in blogger with your favorite editor
+ #
# Copyright (C) 2007 Onur Aslan <onuraslan@gmail.com>
+ #
#
+ #
# This program is free software: you can redistribute it and/or modify
+ #
# it under the terms of the GNU General Public License as published by
+ #
# the Free Software Foundation, either version 3 of the License, or
+ #
# any later version.
+ #
#
+ #
# This program is distributed in the hope that it will be useful,
+ #
# but WITHOUT ANY WARRANTY; without even the implied warranty of
+ #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ #
# GNU General Public License for more details.
+ #
#
+ #
# You should have received a copy of the GNU General Public License
+ #
# along with this program. If not, see <http://www.gnu.org/licenses/>
+. #
######################################################################
+###
use strict;
use Getopt::Long;
use WWW::Mechanize;
my $username; # You can define a default value if you want.
my $password; # Otherwise you must start program with --username and
+ --password
my $tmp_file = "/tmp/addtoblog";
my $editor = "vi";
my $template = "# Addtoblog template
# First line must be your entry Title
# Second line must be must be tags, e.g. scooters, vacation, fall\n";
my $mech = WWW::Mechanize->new ();
my $blog_id;
sub initialize
{
GetOptions ("username=s"=>\$username,
"password=s"=>\$password,
"editor=s", =>\$editor);
unless ($username && $password)
{
die "Addtoblog 0.1\n",
"Add your new entry to your blog in blogger with your favori
+te editor\n",
"Default editor: $editor\n",
"You can change editor with --editor argument.\n",
"Usage:\n",
" ./addtoblog --username=USERNAME --password=PASSWORD\n";
}
}
# Login to blogger
sub login
{
print "Connecting to blogger.com...\n";
$mech->get ("https://www.blogger.com/start");
print "Logining to blogger.com...\n";
$mech->submit_form (
form_name => "login",
fields => { Email => $username,
Passwd => $password },
button => "ok"
);
if ($mech->{form} != undef)
{
die "Wrong username or password.\n";
}
$mech->get ("http://www.blogger.com/home");
# Getting blog id
($blog_id) = $mech->{content} =~ /blogID=([\d]+)/;
}
sub new_post
{
# Creating new post template
open FILE, ">$tmp_file";
print FILE $template;
close FILE;
# Opening tmp_file with vi
print "Opening text editor...\n";
system ("$editor $tmp_file");
# Parsing new post
print "Parsing file...\n";
open FILE, $tmp_file;
my @content;
while (<FILE>)
{
if ($_ !~ /^#/)
{
push @content, $_;
}
}
close FILE;
my $title = $content[0];
$title =~ s/\n//g;
shift @content; # Removing title in @content
my $tags = $content[0];
$tags =~ s/\n//g;
shift @content; # Removing tags in @content
my $content = join ("", @content);
# Print information
print "Title: $title\n",
"Tags: $tags\n",
"Content: $content\n",
"Do you want to post this entry to your blog? [Y|n]: ";
my $a = <>;
if ($a eq "\n" || $a =~ /y/i)
{
print "Posting...\n";
$mech->get ("http://www.blogger.com/post-create.g?blogID=$blog_i
+d");
$mech->submit_form (
form_name => "stuffform",
fields => { title => $title,
postBody => $content,
postLabels => $tags },
button => "publish"
);
print "Your entry successfully posted to your blog.\n";
}
}
initialize;
login;
new_post;
|
Simple threaded chat server
on Jan 17, 2008 at 13:19
|
0 replies
|
by zentara
|
I've seen quite a few questions lately about threaded chat servers. Sockets are confusing enough, but when you add threads into it, complete
mayhem occurs as newbies mix up IO::Select, threads, and forking. Well, here are 2 very basic snippets for threaded chat. The first is non-echo( it connects to many private single clients). The second is multi-echo-chat. It's only trick is the use of fileno's to share socket filehandles across threads. And finally, a Tk client for testing the servers. Of course, threaded servers are not better than forking servers, but they can handle big file transfers without blocking( like select). The drawback is the memory footprint will rise and stay at peak usage.
#!/usr/bin/perl
use warnings;
use strict;
use IO::Socket;
use threads;
$|++;
print $$;
my $server = new IO::Socket::INET(
Timeout => 7200,
Proto => "tcp",
LocalPort => 12345,
Reuse => 1,
Listen => 2
);
my $num_of_client = -1;
while (1) {
my $client;
do {
$client = $server->accept;
} until ( defined($client) );
my $peerhost = $client->peerhost();
print "accepted a client $client, $peerhost, id = ", ++$num_of_cli
+ent, "\n";
#spawn a thread here for each client
my $thr = threads->new( \&processit,$client,$peerhost )->detach();
}
sub processit {
my ($lclient,$lpeer) = @_; #local client
if($lclient->connected){
# Here you can do your stuff
# I use have the server talk to the client
# via print $client and while(<$lclient>)
print $lclient "$lpeer->Welcome to server\n"; #and
#$lclient->recv;
while(<$lclient>){print $lclient "$lpeer->$_\n"}
}
#close filehandle before detached thread dies out
close( $lclient);
}
__END__
# slightly modified version of above to add multi-echo-chat
#!/usr/bin/perl
use warnings;
use strict;
use IO::Socket;
use threads;
use threads::shared;
$|++;
print "$$ Server started\n";; # do a "top -p -H $$" to monitor server
+ threads
our @clients : shared;
@clients = ();
my $server = new IO::Socket::INET(
Timeout => 7200,
Proto => "tcp",
LocalPort => 12345,
Reuse => 1,
Listen => 3
);
my $num_of_client = -1;
while (1) {
my $client;
do {
$client = $server->accept;
} until ( defined($client) );
my $peerhost = $client->peerhost();
print "accepted a client $client, $peerhost, id = ", ++$num_of_cli
+ent, "\n";
my $fileno = fileno $client;
push (@clients, $fileno);
#spawn a thread here for each client
my $thr = threads->new( \&processit, $client, $fileno, $peerhost )
+->detach();
}
# end of main thread
sub processit {
my ($lclient,$lfileno,$lpeer) = @_; #local client
if($lclient->connected){
# Here you can do your stuff
# I use have the server talk to the client
# via print $client and while(<$lclient>)
print $lclient "$lpeer->Welcome to server\n";
while(<$lclient>){
# print $lclient "$lpeer->$_\n";
print "clients-> @clients\n";
foreach my $fn (@clients) {
open my $fh, ">&=$fn" or warn $! and die;
print $fh "$lpeer->$_"
}
}
}
#close filehandle before detached thread dies out
close( $lclient);
#remove multi-echo-clients from echo list
@clients = grep {$_ !~ $lfileno} @clients;
}
__END__
# and finally a Tk client to test with
#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use IO::Socket;
require Tk::ROText;
#get id
my $name = shift || 'anon';
# create the socket
my $host = 'localhost';
my $port = 12345;
my $socket = IO::Socket::INET->new(
PeerAddr => $host,
PeerPort => $port,
Proto => 'tcp',
);
defined $socket or die "ERROR: Can't connect to port $port on $host: $
+!\n";
print STDERR "Connected to server ...\n";
my $mw = new MainWindow;
my $log = $mw->Scrolled('ROText',
-scrollbars=>'ose',
-height=> 5,
-width=>45,
-background => 'lightyellow',
)->pack;
my $txt = $mw->Entry(
-background=>'white',
)->pack(-fill=> 'x', -pady=> 5);
$mw ->bind('<Any-Enter>' => sub { $txt->Tk::focus });
$txt->bind('<Return>' => [\&broadcast, $socket]);
$mw ->fileevent($socket, readable => sub {
my $line = <$socket>;
unless (defined $line) {
$mw->fileevent($socket => readable => '');
return;
}
$log->insert(end => $line);
$log->see('end');
});
MainLoop;
sub broadcast {
my ($ent, $sock) = @_;
my $text = $ent->get;
$ent->delete(qw/0 end/);
print $sock $name.'->'. $text, "\n";
}
__END__
|
One-liner Youtube Downloader
on Dec 23, 2007 at 19:54
|
2 replies
|
by Onur
|
This program downloading youtube videos with using wget. Videos are directly downloading. If you want to convert downloaded videos to mpeg from flv, you must have ffmpeg and add this code to end of the program:
`ffmpeg -i $_[1] -ab 128 -ar 44100 -b 500 -s 320x240 $_[1].mpg`;
Using:
perl youtube-downloader http://www.youtube.com/watch?v=dXmKDkAAamc
use strict;use LWP::Simple;@_ = get ($ARGV[0]) =~ /var swfArgs = {hl:'
+en',(video_id):'([\w_-]{11,11})',(l):'([\d]+)',(t):'([\w_-]+)',(sk):'
+([\w_-]+)'};/;my $url = "http://www.youtube.com/get_video.php?";for (
+my $i = 0; $i < @_; $i = $i + 2){$url .= "&" . $_[$i] . "=" . $_[$i+1
+];}`wget -O $_[1].flv "$url"`;
|
ISONUM Entities
on Nov 17, 2007 at 15:27
|
1 reply
|
by Sixtease
|
Some texts contain weird SGML entities: ] \ etc. I found out that these are ISONUM entities. Here is a hash that maps the names to the unicode characters, extracted from the table linked above. It is ready to be used in the HTML::Entities::_decode_entities function.
{
'amp' => chr(0x00026),
'amp;' => chr(0x00026),
'apos' => chr(0x00027),
'apos;' => chr(0x00027),
'ast' => chr(0x0002A),
'ast;' => chr(0x0002A),
'brvbar' => chr(0x000A6),
'brvbar;' => chr(0x000A6),
'bsol' => chr(0x0005C),
'bsol;' => chr(0x0005C),
'cent' => chr(0x000A2),
'cent;' => chr(0x000A2),
'colon' => chr(0x0003A),
'colon;' => chr(0x0003A),
'comma' => chr(0x0002C),
'comma;' => chr(0x0002C),
'commat' => chr(0x00040),
'commat;' => chr(0x00040),
'copy' => chr(0x000A9),
'copy;' => chr(0x000A9),
'curren' => chr(0x000A4),
'curren;' => chr(0x000A4),
'darr' => chr(0x02193),
'darr;' => chr(0x02193),
'deg' => chr(0x000B0),
'deg;' => chr(0x000B0),
'divide' => chr(0x000F7),
'divide;' => chr(0x000F7),
'dollar' => chr(0x00024),
'dollar;' => chr(0x00024),
'equals' => chr(0x0003D),
'equals;' => chr(0x0003D),
'excl' => chr(0x00021),
'excl;' => chr(0x00021),
'frac12' => chr(0x000BD),
'frac12;' => chr(0x000BD),
'frac14' => chr(0x000BC),
'frac14;' => chr(0x000BC),
'frac18' => chr(0x0215B),
'frac18;' => chr(0x0215B),
'frac34' => chr(0x000BE),
'frac34;' => chr(0x000BE),
'frac38' => chr(0x0215C),
'frac38;' => chr(0x0215C),
'frac58' => chr(0x0215D),
'frac58;' => chr(0x0215D),
'frac78' => chr(0x0215E),
'frac78;' => chr(0x0215E),
'gt' => chr(0x0003E),
'gt;' => chr(0x0003E),
'half' => chr(0x000BD),
'half;' => chr(0x000BD),
'horbar' => chr(0x02015),
'horbar;' => chr(0x02015),
'hyphen' => chr(0x02010),
'hyphen;' => chr(0x02010),
'iexcl' => chr(0x000A1),
'iexcl;' => chr(0x000A1),
'iquest' => chr(0x000BF),
'iquest;' => chr(0x000BF),
'laquo' => chr(0x000AB),
'laquo;' => chr(0x000AB),
'larr' => chr(0x02190),
'larr;' => chr(0x02190),
'lcub' => chr(0x0007B),
'lcub;' => chr(0x0007B),
'ldquo' => chr(0x0201C),
'ldquo;' => chr(0x0201C),
'lowbar' => chr(0x0005F),
'lowbar;' => chr(0x0005F),
'lpar' => chr(0x00028),
'lpar;' => chr(0x00028),
'lsqb' => chr(0x0005B),
'lsqb;' => chr(0x0005B),
'lsquo' => chr(0x02018),
'lsquo;' => chr(0x02018),
'lt' => chr(0x0003C),
'lt;' => chr(0x0003C),
'micro' => chr(0x000B5),
'micro;' => chr(0x000B5),
'middot' => chr(0x000B7),
'middot;' => chr(0x000B7),
'nbsp' => chr(0x000A0),
'nbsp;' => chr(0x000A0),
'not' => chr(0x000AC),
'not;' => chr(0x000AC),
'num' => chr(0x00023),
'num;' => chr(0x00023),
'ohm' => chr(0x02126),
'ohm;' => chr(0x02126),
'ordf' => chr(0x000AA),
'ordf;' => chr(0x000AA),
'ordm' => chr(0x000BA),
'ordm;' => chr(0x000BA),
'para' => chr(0x000B6),
'para;' => chr(0x000B6),
'percnt' => chr(0x00025),
'percnt;' => chr(0x00025),
'period' => chr(0x0002E),
'period;' => chr(0x0002E),
'plus' => chr(0x0002B),
'plus;' => chr(0x0002B),
'plusmn' => chr(0x000B1),
'plusmn;' => chr(0x000B1),
'pound' => chr(0x000A3),
'pound;' => chr(0x000A3),
'quest' => chr(0x0003F),
'quest;' => chr(0x0003F),
'quot' => chr(0x00022),
'quot;' => chr(0x00022),
'raquo' => chr(0x000BB),
'raquo;' => chr(0x000BB),
'rarr' => chr(0x02192),
'rarr;' => chr(0x02192),
'rcub' => chr(0x0007D),
'rcub;' => chr(0x0007D),
'rdquo' => chr(0x0201D),
'rdquo;' => chr(0x0201D),
'reg' => chr(0x000AE),
'reg;' => chr(0x000AE),
'rpar' => chr(0x00029),
'rpar;' => chr(0x00029),
'rsqb' => chr(0x0005D),
'rsqb;' => chr(0x0005D),
'rsquo' => chr(0x02019),
'rsquo;' => chr(0x02019),
'sect' => chr(0x000A7),
'sect;' => chr(0x000A7),
'semi' => chr(0x0003B),
'semi;' => chr(0x0003B),
'shy' => chr(0x000AD),
'shy;' => chr(0x000AD),
'sol' => chr(0x0002F),
'sol;' => chr(0x0002F),
'sung' => chr(0x0266A),
'sung;' => chr(0x0266A),
'sup1' => chr(0x000B9),
'sup1;' => chr(0x000B9),
'sup2' => chr(0x000B2),
'sup2;' => chr(0x000B2),
'sup3' => chr(0x000B3),
'sup3;' => chr(0x000B3),
'times' => chr(0x000D7),
'times;' => chr(0x000D7),
'trade' => chr(0x02122),
'trade;' => chr(0x02122),
'uarr' => chr(0x02191),
'uarr;' => chr(0x02191),
'verbar' => chr(0x0007C),
'verbar;' => chr(0x0007C),
'yen' => chr(0x000A5),
'yen;' => chr(0x000A5),
}
|
One-liner to build a Trie
on Oct 30, 2007 at 01:40
|
1 reply
|
by graff
|
Many of us have written (and posted) code to build a "prefix" hash (a.k.a Trie indexes), but I wanted a quick command line to do this for word tokens over a set of short phrases. Allowing that Data::Dumper output would suffice, the solution was pretty short. (updated to fix the link to CPAN)
perl -MData::Dumper -lne '$i=\%h; for(split){$$i{$_}{N}++; $i=$$i{$_}}
END{print Dumper(\%h)}'
|
Net::SCP::Expect
on Oct 24, 2007 at 15:45
|
1 reply
|
by j^2
|
Here is a script to use Net::SCP::Expect module. It's useful if you have to pull data from alot of different machines. I put it in a for loop in bash with the different server names.
#!/usr/bin/perl
use Net::SCP::Expect;
my $scpe= Net::SCP::Expect->new;
$svr = $ARGV[0];
$type = $ARGV[1];
$date = $ARGV[2];
print "$svr ";
$scpe->login('root', 'foo');
$scpe->scp("$svr:/var/log/ems/$type.$date.log", "/home/me/logs/$type.$
+svr.$date.log");
print "....done\n";
|
Sourcing shell scripts
on Oct 18, 2007 at 22:05
|
4 replies
|
by tuxz0r
|
I thought this might come in handy for someone. This is a useful way to source a shell script to make environment variables available to your Perl script.
In our batch systems at work we primarily write our code in Perl. However, we have a number of small utilities written in shell that we use in debugging, plus we have a script that gets sourced on login that gives us access to our Database and other resources in the environment. In previous days we wrote a wrapper shell script which sourced the shell script prior to calling the Perl scripts, but this was tedious and you had to remember to use it if you ran one of the scripts from the command line, from cron, etc.
Using this short bit of code, taking advantage of the '-s' option to Perl, we can eliminate the use of the wrapper script completely.
eval {
exec ". ./env.sh; /usr/bin/perl -s $0 -env -- @ARGV";
} unless $env;
I've seen other solutions for this, but some rely on running the script as in a system() or open() call and then parsing the output of the 'env' command to read in and set any environment variables that were exported.
If you've used other workarounds for this, I'd be interested in seeing those, too! Hope this helps someone out.
|
Generate GUID from a string
on Oct 18, 2007 at 21:18
|
0 replies
|
by GrandFather
|
use Digest::MD5 qw(md5_hex);
# Generate a GUID given a string
sub genGUID {
my $seed = shift;
my $md5 = uc md5_hex ($seed);
my @octets = $md5 =~ /(.{2})/g;
substr $octets[6], 0, 1, '4'; # GUID Version 4
substr $octets[8], 0, 1, '8'; # draft-leach-uuids-guids-01.txt GUI
+D variant
my $GUID = "{@octets[0..3]-@octets[4..5]-@octets[6..7]-@octets[8..
+9]-@octets[10..15]}";
$GUID =~ s/ //g;
return $GUID;
}
|
Dumping from any RDBMS to CSV
on Oct 18, 2007 at 16:26
|
0 replies
|
by jZed
|
Using RDBMS-specific dumps like MySQL's "SELECT INTO OUTFILE" is probably faster. But in case your RDBMS doesn't have one or you want something that is portable across all DBI-accessible RDBMSs, here's an example. You can substitute any DBD for XBase and use any SELECT statement that is supported by that DBD. Under the hood, SQL::Statement will use that DBD to read row by row from the source and use Text::CSV_XS to write row by row to the target.
To use different separators, delimters, or escapes, use DBD::CSV's csv_tables, for example for a so-called "Tab Delimted" file with *nix line endings:
$dbhC->{csv_tables}->{outTable} = {
file => 'foo/bar.csv',
sep_char => "\t",
eol => '\012',
};
If you omit the csv_tables defintion, then the table name will be used for the filename and the separator will be a comma, the delimiter a quote mark and the line ending windows-style '\015\012'.
#!/usr/bin/perl
use warnings;
use strict;
use DBI;
my $dbhX = DBI->connect('dbi:XBase(RaiseError=1):');
my $dbhC = DBI->connect('dbi:CSV(RaiseError=1):');
my $select = $dbhX->prepare("SELECT * FROM inTable");
$select->execute();
$dbhC->do("CREATE TABLE outTable AS IMPORT(?)",{},$select);
__END__
|
Test that a module's SYNOPSIS code really runs
on Oct 16, 2007 at 21:42
|
1 reply
|
by Jeffrey Kegler
|
In reformatting the code in the POD's SYNOPSIS section of a CPAN module I'm writing, it struck me that it's easy to accidentally break the code. Nice to have at least the code in the SYNOPSIS run! So I created a synopsis.t.
UPDATE: Fixed two bugs. synopsis.t no longer reports success if it can't open the POD file. And it no longer depends on the file being in a specific location.
enjoy, Jeffrey Kegler
use strict;
use warnings;
use English;
use Test::More tests => 2;
# Module specific stuff here -- setup code
use Scalar::Util qw(weaken isweak);
BEGIN { use_ok('Test::Weaken') };
package Module::Test_me1; sub new { bless [], (shift); }
package Module::Test_me2; sub new { bless [], (shift); }
package main;
# slurp in the code
my $filename = $INC{"Test/Weaken.pm"};
unless (open(CODE, $filename)) {
fail("Cannot open $filename");
exit(1);
}
$RS = undef;
my $code = <CODE>;
# remove stuff before and after the SYNOPSIS
$code =~ s/.*^=head1\s*SYNOPSIS\s*$//xms;
$code =~ s/^=cut.*\z//xms;
# remove POD text
$code =~ s/^\S[^\n]*$//xmsg;
# compute line count -- don't include whitespace lines
$code =~ s/^\s*$//xmsg;
my @lines = split(/\n/, $code);
my $line_count = @lines;
# check for absence of code
if ($code =~ /\A\s*\z/xms) {
fail("No code in synopsis");
exit(1);
}
# Try the code and see what happens
eval $code;
# Report the results
if ($@) {
fail("Synopsis code failed: $@");
} else {
pass("Synopsis has $line_count lines of good code");
}
|
|