Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

Cool Uses for Perl

( #1044=superdoc: print w/ replies, xml ) Need Help??

This section is the place to post your general code offerings.

CUFP's
Check popular review sites for new reviews.
1 direct reply — Read more / Contribute
by wrinkles
on Jul 28, 2014 at 19:25

    This script checks select pages on some popular review sites for the latest review, and writes the date of the most recent review from each site to a file. Each time it is run, it checks against the previous results and sends an email notification with the date and link to page(s) with fresh reviews.

    "mailx" was used to send email. I suspect that this may not be available in Windows, I tested only on Mac OS X and Ubuntu.

    The following script has the pages hard-coded, as it was written for my school. Those pages (and your email addresses) could easily be replaced to suit your requirements.

    I found "The 10-minute XPath Tutorial" ("Automating System Administration with Perl, 2nd ed.) very helpful in understanding XPath. Thanks also to the help of fellow perl monks!

    By the way, "EB" and "MA" are shorthand for two separate campuses within our school.

    Update 2014-07-28 - I ran perlcritic and fixed some potential problems

    #!/usr/bin/env perl use strict; use warnings; use utf8; use Text::CSV; use Carp; use LWP::Simple qw(get); use Text::Unidecode qw(unidecode); use HTML::TreeBuilder::XPath; # Email Settings my %email = ( to => 'me@example.com,you@example.com', subject => 'New ECDS reviews found' ); # Reviews subroutine and URLs to check my $review_sites = [ { site => 'Yelp', sub => \&yelp_checker, review_pages => { 'EB' => 'http://www.yelp.com/biz/encinitas-country-day-school-encinitas?sort_b +y=date_desc', 'MA' => 'http://www.yelp.com/biz/encinitas-country-day-school-encinitas-2?sort +_by=date_desc' } }, { site => 'GreatSchools', sub => \&gs_checker, review_pages => { 'MA' => 'http://www.greatschools.org/california/encinitas/9670-Encinitas-Count +ry-Day-School/?tab=reviews' } }, { site => 'PrivateSchoolReview', sub => \&psr_checker, review_pages => { 'MA' => 'http://www.privateschoolreview.com/school_ov/school_id/ +2039' } }, { site => 'Kudzu', sub => \&kudzu_checker, review_pages => { 'MA' => 'http://www.kudzu.com/m/Encinitas-Country-Day-School-135 +71675' } }, { site => 'MerchantCircle', sub => \&mc_checker, review_pages => { 'MA' => 'http://www.merchantcircle.com/business/Encinitas.Country.Day.School.7 +60-942-1111?sort=created&dir=desc' } } ]; # Default date if no record my $default_date = '00-00-0000'; # Month name to number conversion my %month = ( January => '01', February => '02', March => '03', April => '04', May => '05', June => '06', July => '07', August => '08', September => '09', October => '10', November => '11', December => '12' ); # Where is the reviews file? my $reviews_filepath = "reviews.txt"; # Where is the alert message file? my $msg_filepath = "msg.txt"; # Slurp hash from reviews file my $old_reviews = hash_from_csv($reviews_filepath); my %new_reviews; # Iterate through each site for my $review_site (@$review_sites) { my $pages = $review_site->{review_pages}; # iterate through each campus html and collect xpath nodes while ( my ( $campus, $url ) = each %$pages ) { my $html = get $url or croak("Can't reach $url $!\n"); $html =~ s/([^[:ascii:]]+)/unidecode($1)/ge; my $tree = HTML::TreeBuilder::XPath->new; $tree->parse($html) or croak("Parse failed: $!\n"); my ($date) = $review_site->{'sub'}->($tree); # create hash keys from campus and review site names my $campus_site = $campus . '_' . $$review_site{'site'}; push( @{ $new_reviews{$campus_site} }, $date ); push( @{ $new_reviews{$campus_site} }, $url ); } } # Write message if new reviews my $msg = ''; while ( my ( $item, $data ) = each %new_reviews ) { unless ( $$old_reviews{$item}[0] eq $$data[0] ) { $msg .= "New review on $$data[0]: \n $$data[1]\n"; } } # Save message. open my $fh, ">:encoding(utf8)", "$msg_filepath" or croak("cannot open $msg_filepath: $!"); print {$fh} $msg or croak("Can't print message:\n$msg\n$!"); close $fh; # Write new review data to file. hash_to_csv( \%new_reviews, $reviews_filepath ); # Email message if exists send_email($msg) if length($msg); ######## SUBROUTINES ####### # import old data from file sub hash_from_csv { my $filepath = shift; open my $fh, "<:encoding(utf8)", "$filepath" or croak("cannot open $filepath: $!"); my $csv = Text::CSV->new( { binary => 1 } ); my %hash; map { $hash{ shift @{$_} } = $_ } @{ $csv->getline_all($fh) }; close $fh; return \%hash; } # write new data to file sub hash_to_csv { my ( $hash, $filepath ) = @_; open my $fh, ">:encoding(utf8)", "$filepath" or croak("cannot open $filepath: $!"); my $csv = Text::CSV->new( { binary => 1, eol => "\n" } ); for ( keys %$hash ) { my $colref = [ $_, $$hash{$_}->[0] ]; $csv->print( $fh, $colref ); } close $fh; return; } # send email notifications sub send_email { my ($body) = @_; open my $pipe, '|-', '/usr/bin/mailx', '-s', $email{subject}, $ema +il{to} or croak("can't open pipe to mailx: $!\n"); print $pipe $body; close $pipe; croak("mailx exited with a non-zero status: $?\n") if $?; return; } # extract date of most recent review from GreatSchools tree sub gs_checker { my $tree = shift; my $xpath = '//div[contains(@class,"media mbs")]/div[(@class="author small make-99 +9999 fl pbn mbn")]'; my $dates = $tree->findnodes($xpath); # dates returned as 'month dd, yyyy' my $date; $date = $$dates[0]->as_trimmed_text() if ( $$dates[0] ); if ( $date =~ /(\w{3,9})\s+(\d{1,2}),\s+(\d{4})/ ) { $date = $3 . '-' . $month{$1} . '-' . $2; } return ( $date || $default_date ); } # extract date of most recent review from Yelp tree sub yelp_checker { my $tree = shift; my $xpath = '//meta[@itemprop="datePublished"][1]'; my $dates = $tree->findnodes($xpath); # dates returned as 'yyyy-mm-dd' if ( $$dates[0] ) { return $$dates[0]->attr('content'); } else { return ( $$dates[0] || $default_date ); } } # extract date of most recent review from PrivateSchoolReview tree sub psr_checker { my $tree = shift; my $xpath = '//meta[@itemprop="datePublished"][1]'; my $dates = $tree->findnodes($xpath); # dates returned as 'yyyy-mm-dd' if ( $$dates[0] ) { return $$dates[0]->attr('content'); } else { return ( $$dates[0] || $default_date ); } } # extract date of most recent review from Kudzu tree sub kudzu_checker { my $tree = shift; my $xpath = '//div[@class="review_post_date"]/p/span[@class="rp-da +te"]'; my $dates = $tree->findnodes($xpath); # date returned as 'mm/dd/yyyy' my $date; $date = $$dates[0]->as_trimmed_text() if ( $$dates[0] ); if ( $date =~ /(\d{1,2})\/(\d{1,2})\/(\d{4})/ ) { $date = $3 . '-' . $1 . '-' . $2; } return ( $date || $default_date ); } # extract date of most recent review from MerchantCircle tree sub mc_checker { my $tree = shift; my $xpath = '//span[@itemprop="datePublished"][1]'; my $dates = $tree->findnodes($xpath); # dates returned as 'Month dd, yyyy at hh:mm PM' my $date; $date = $$dates[0]->as_trimmed_text() if ( $$dates[0] ); if ( $date =~ /\s*(\w{3,9})\s*(\d{1,2})\s*\,\s*(\d{4})\s+at\s+\d{1,2}\:\d{2} +\s+[AP]M/ ) { $date = $3 . '-' . $month{$1} . '-' . $2; } return ( $date || $default_date ); }
Install missing modules with Module::Extract::Install's cpanm-missing/cpanm-missing-deep
No replies — Read more | Post response
by frozenwithjoy
on Jul 24, 2014 at 12:07

    The other day I got a new laptop and tried to run a couple scripts on it. I quickly grew tired of the tedious cycle of 'Module::X not found' errors/installing Module::X. I decided to make a tool to improve the situation.

    The result, Module::Extract::Install, can be used to analyze perl scripts and modules to identify and install their dependencies in an automated, pain-free manner. You can use this module's methods to write your own script (e.g., to pipe missing modules to your favorite installer) or take advantage of the included command-line tools cpanm-missing (checks a list of Perl files) and cpanm-missing-deep (checks all the Perl files within a directory).

    Feel free to give me last minute comments/suggestions before I put it on CPAN (currently it is only available through GitHub). Thanks!

SysV shared memory (Look-Alike) -- pure perl
3 direct replies — Read more / Contribute
by flexvault
on Jul 20, 2014 at 16:42

    Dear Monks,

    I have stayed away from using shared memory because of the statement: "This function is available only on machines supporting System V IPC." in the documentation for use. I decided I had a good use and did a Super Search and found zentara's excellent work which I used as a starting point for this discussion. I re-read the documentation and looked at the books 'Programming Perl' and the 'Perl Cookbook', and wondered if I could do something similar with a RAM disk and not have a dependency on System V IPC support. So taking the code provided by zentara, and using it as a benchmark for my requirements, I started testing on a 8GB RAM disk on a Debian 64bit Linux box using a 32-bit 5.14.2 Perl. I found that I could get approximately 216K System V IPC writes per second(wps). WOW!

    Since I only needed 20-25K writes per second, I started working on my "shared memory look-alike". What I found was that I could do better than 349K wps. Actually the 1st run produced 800K wps, but I realized I didn't follow the format of zentara's script, so I modified the script to call a subroutine, flock the file, test return codes, etc. Currently, 349K wps is the worse case on a RAM disk, 291K wps on a 7,200 rpm hard disk, and 221K wps on a 5,400 rpm disk. (Note: I didn't have a SSD on the test system.) The code follows, and if I did something to make my numbers look better, I'd like to know.

    Update: Do not use this code as it mixes buffered and unbuffered I/O. See later for a sample that I believe works correctly!

    ####### shmem-init.pl ############################ #!/usr/bin/perl use warnings; use strict; use Time::HiRes qw( gettimeofday usleep ); use Fcntl qw( :DEFAULT :flock ); ## Part of core perl use IPC::SysV qw(IPC_STAT IPC_PRIVATE IPC_CREAT IPC_EXCL S_IRUSR S_IWU +SR IPC_RMID); # see "perldoc perlfunc /shmget" and "perldoc perlipc /SysV" # big difference from c is attach and detach is automatic in Perl # it attaches to read or write, then detaches my $go = 1; $SIG{INT} = sub{ $go = 0; &close_m(); #close up the shared mem exit; }; my $segment_hbytes = 0x640; # hex bytes, a multiple of 4k my ($segment_id, $segment_size) = &init_m($segment_hbytes); print "shmid-> $segment_id\tsize-> $segment_size\n"; # Counter Elap +sed time Writes/second # ------------- +---------------------------- my $stime = gettimeofday; my $i = 0; # Result: 2000000 9.27 +134203910828 215718/second while($go) { &write_m($i); $i++; if ( $i >= 2_000_000 ) { $stime = gettimeofday - $stime; my $rpm = int( 2_000_000 / + $stime ); print "$i\t$stime\t$rpm/second\n\n"; last; } #select(undef,undef,undef,.001); last if ! $go; } our $indexdb; # Counter Ela +psed time Writes/second # ------------ +----------------------------- my $file = "/dev/shm/FlexBase/__env.index"; # Result: 2000000 5.7 +3024797439575 349025/second # my $file = "/__env.index"; # Result: 2000000 6.8 +8051080703735 290676/second # my $file = "/flexvault/__env.index"; # Result: 2000000 9.0 +2671384811401 221564/second open( $indexdb,"+<", $file ) or die "Not open: $!"; $stime = gettimeofday; $i = 0; while( 1 ) { &write_mem($i); $i++; if ( $i >= 2_000_000 ) { $stime = gettimeofday - $stime; my $rpm = int( 2_000_000 / + $stime ); print "$i\t$stime\t$rpm/second\n"; last; } } close $indexdb; exit; sub write_mem() { our $indexdb; # Write a string to the shared file. my $message = shift; if ( flock( $indexdb, LOCK_EX ) ) { my $ret = sysseek( $indexdb, 0, 0); # move to beginning of fil +e if ( ! defined $ret ) { die "O04. sysseek failed: $!"; } $ret = syswrite ( $indexdb, $i, length($i) ); if ( $ret != length($i) ) { die "O05. syswrite failed! $!"; } } ## ## Make test ( 1==1 ) to verify syswrite worked correctly. ## Make test ( 1==2 ) to test speed of syswrite to filesystem. ## if ( ( 1==2 )&&( flock( $indexdb, LOCK_SH ) ) ) { my $ret = sysseek( $indexdb, 0, 0); # move to beginning of fil +e if ( ! defined $ret ) { die "O06. sysseek failed: $!"; } $ret = sysread ( $indexdb, my $ni, length($i) ); if ( $ni != $i ) { die "O07. |$ni|$i| $!"; } } return 0; } ################################################################# sub init_m(){ my $segment_hbytes = shift; # Allocate a shared memory segment. my $segment_id = shmget (IPC_PRIVATE, $segment_hbytes, IPC_CREAT | IPC_EXCL | S_IRUSR | S_IWUSR); # Verify the segment's size. my $shmbuffer = ''; shmctl ($segment_id, IPC_STAT, $shmbuffer); my @mdata = unpack("i*",$shmbuffer); #not sure if that is right unp +ack? works :-) return($segment_id, $mdata[9] ); } sub write_m() { # Write a string to the shared memory segment. my $message = shift; shmwrite($segment_id, $message, 0, $segment_size) || die "$!"; #the 0, $segment_size can be broke up into substrings like 0,60 # or 61,195, etc return 0; } sub close_m(){ # Deallocate the shared memory segment. shmctl ($segment_id, IPC_RMID, 0); return 0; } 1; __END__

    Regards...Ed

    "Well done is better than well said." - Benjamin Franklin

Yahoo Content Analyzer
No replies — Read more | Post response
by Your Mother
on Jul 20, 2014 at 16:34

    Inspired by How to transmit text to Yahoo Content Analysis. Not sure how complete or correct it is, just threw it together for fun. Seems to work and Iíll make amendments as necessary or sanely suggested.

    Requires: strictures, LWP::UserAgent, Getopt::Long, Pod::Usage, Path::Tiny.

    #!/usr/bin/env perl use 5.010; use strictures; no warnings "uninitialized"; use LWP::UserAgent; use Getopt::Long; use Pod::Usage; use open qw( :encoding(UTF-8) :std ); use Path::Tiny; # use XML::LibXML; # For expansion... or XML::Rabbit my $service = "http://query.yahooapis.com/v1/public/yql"; my %opt = ( text => undef, url => undef, max => 100 ); # These are, luckily, false by default for Yahoo, so we only care abou +t true. my %boolean = map {; $_ => 1 } qw/ related_entities show_metadata enable_categorizer /; # What we compose to query, e.g. not "verbose" or "file." my %sql = ( %opt, %boolean ); my $ok = GetOptions( \%opt, "text=s", "file=s", "url=s", "max=i", "verbose", "help", keys %boolean ); pod2usage( -verbose => 0, -exitval => 1, -message => "Options were not recognized." ) unless $ok; pod2usage( -verbose => 2 ) if $opt{help}; pod2usage( -verbose => 0, -exitval => 1, -message => "One of these, at most, allowed: text, url, fil +e." ) if 1 < grep defined, @opt{qw/ text url file /}; # Only one, text|file, is allowed by Getopt::Long. $opt{text} ||= path($opt{file})->slurp if $opt{file}; unless ( $opt{url} || $opt{text} ) # Accept from STDIN. { say "Type away. ^D to execute (on *nix anyway)."; chomp( my @input = <> ); $opt{text} = join " ", @input; die "Give some input!\n" unless $opt{text} =~ /\w/; } my @where; for my $key ( keys %opt ) { next unless defined $opt{$key} and exists $sql{$key}; $opt{$key} = "true" if $boolean{$key}; $opt{$key} =~ s/([\\"'\0])/\\$1/g; push @where, sprintf "%s = '%s'", $key, $opt{$key}; } my $q = sprintf "SELECT * FROM contentanalysis.analyze WHERE %s", join " AND ", @where; say "SQL >> $q\n" if $opt{verbose}; my $ua = LWP::UserAgent->new; my $response = $ua->post( $service, [ q => $q ] ); say $response->request->as_string if $opt{verbose}; say $opt{verbose} ? $response->as_string : $response->decoded_content(); exit ! $response->is_success; __END__ =pod =encoding utf8 =head1 Name yahoo-content-analyzer - command-line to query it. =head1 Synopsis yahoo-content-analyzer -text "Perl is a programming language." -text "{command line string}" -file (slurp and submit as text) -url -max [100 is default] -related_entities -show_metadata -enable_categorizer -verbose -help =head1 Description L<https://developer.yahoo.com/search/content/V2/contentAnalysis.html> =head1 Code Repository L<http://perlmonks.org/?node_id=1094394> =head1 See Also L<https://metacpan.org/search?q=YQL>. =head1 Author and License Your Mother, L<http://perlmonks.org/?node_id=248054>. You may redistribute and modify this code under the same terms as Perl itself. =head1 Disclaimer of Warranty No warranty. No means no. =cut

    Updates/Changelog

    • Removed URI, only first draft used it.
commandline ftpssl client with Perl
1 direct reply — Read more / Contribute
by zentara
on Jul 05, 2014 at 12:37
    Recently, all my c-based ftpssl programs stopped working with ssl, namely gftp and lftp. I found that Net::FTPSSL still works great, but it isn't interactive, it allows just automated scripting. So, how to make an interactive session? I first thought of using a gui, but there was no real advantage to the gui, over the commandline, ( not without a huge amount of work ;-) ), so a simple commandline program fit the bill. Here it is. There is a second program below it, which runs it from a pty, in anticipation of channeling it into a Tk or GTk gui; but the gui's seems to have difficulty capturing the tty. If anyone can show how to get the ftpssl tty pty output into a textbox, I would be grateful.

    If you want to experiment on your own machine, Proftd works good when configured with --enable-tls, you can google for instructions.

    I used a little eval trick to pass the commands into the pty.

    Some common commands : list pwd cwd noop nlst mkdir('foo') rmdir('foo') put('somelocalfile', 'remotefile')

    The method set that comes with Net::FTPSSL is simple and easy.

    ftps-z: runs standalone or thru a pty as shown below

    #!/usr/bin/perl use strict; use warnings; use Net::FTPSSL; my $server = "127.0.0.1"; my $username = "someuser"; my $passwd = "somepass"; my @ret; my $ftps = Net::FTPSSL->new($server, Encryption => EXP_CRYPT, Debug => 1, # Croak => 1, ) or die "Can't open $server\n$Net::FTPSSL::ERRSTR"; $ftps->login($username, $passwd) or error("Credential error, $ftps->last_message"); # get default listing and pwd @ret = $ftps->list() or error("Command error, $ftps->last_message"); print "####################\n"; print join "\n", @ret,"\n"; print "####################\n"; # get default pwd @ret = $ftps->pwd or error("Command error, $ftps->last_message"); print "####################\n"; print join "\n", @ret,"\n"; print "####################\n"; if( -t STDIN ) { print "tty\n"; } while(1){ print "Hit Control-C to exit ... otherwise:\n"; print "Enter command: \n"; my $com = <STDIN>; chomp $com; if ($com =~ m/quit/){ print "exiting\n";} # needed this eval to get ftps methods to work with pty my @ret = eval "\$ftps->$com"; if($@) { print "@_\n"; } print "####################\n"; print join "\n", @ret,"\n"; print "####################\n"; if ($com =~ m/quit/){ print "exit command received, ftpssl exiting\n"; + print "Control-C to exit pty, or Shift-PageUp to + view log\n"; last; } } print "at end\n"; exit;
    IO-Pty-driver for above ftps-z
    #!/usr/bin/perl -w # Description: Fool a process into # thinking that STDOUT is a terminal, when in fact # basic PTY code from etcshadow use warnings; use strict; use IO::Pty; $SIG{CHLD} = 'IGNORE'; # for when we quit the ftpssl session my $pty = IO::Pty->new; my $slave = $pty->slave; open TTY,"/dev/tty" or die "not connected to a terminal\n"; $pty->clone_winsize_from(\*TTY); close TTY; my $pid = fork(); die "bad fork: $!\n" unless defined $pid; if (!$pid) { open STDOUT,">&=".$pty->fileno() or die $!; exec "./ftps-z"; }else{ $pty->close(); while (defined (my $line = <$slave>)) { print $line; } } while(1){ my $command = <>; print $slave "$command\n"; }

    I'm not really a human, but I play one on earth.
    Old Perl Programmer Haiku ................... flash japh
Vim: Auto highlight of variables
No replies — Read more | Post response
by Loops
on Jun 27, 2014 at 18:49

    So Ovid made this blog post that gave an example of editing Perl in Vim -- when you move your cursor over a Perl variable it is highlighted in the rest of the document automatically. Quite handy.

    Paul Johnson then made some improvements and put the code in a Git repo so that it's very easy to install with Pathogen in Vim

    After cloning that repo into your Pathogen bundle directory, it pretty much just works as advertised. For some reason it does not work with Tim Popes "vim-sensible" plugin however.

    The highlighting is delayed until you haven't moved your cursor for the number of milliseconds set in the Vim "updatetime" variable. By default this is set to 4000 which is pretty slow. Doing "set ut=50" in your vimrc makes it much snappier.

    Enjoy.

    P.S. Anyone have an updated syntax file for 5.20.0 sub-signatures and other new features?

WWW::Mechanize inventory update for musicstack.com
No replies — Read more | Post response
by maruhige
on Jun 24, 2014 at 11:21

    Spent a bit longer on this than needs be with hindsight, so I figure i'd share the product of that time

    Music stack doesn't have much in the way of an API, instead it requires manual navigation to upload change files. The change file also has an enormous amount of saved customisations on the upload form which would be numbingly tedious to fill out manually in the $mech itself

    So! here's a short and effective means of putting inventory files up on Music Stack, using WWW::Mechanize to navigate from the login screen to the upload screen.

    use WWW::Mechanize; my $username = 'x@example.com'; my $password = 'mypw'; my $upfile = '/path/to/additions.csv'; my $mech = WWW::Mechanize->new() or die $!; $mech->cookie_jar(HTTP::Cookies->new()); $mech->get(q#http://www.musicstack.com/login.cgi#) or die $!; #need to use sequential identifiers when forms are either nameless + or share the same name $mech->form_number(3); $mech->field ('user' => $username); $mech->field ('pw' => $password); $mech->click_button(name => "login"); #now on the user account page $mech->follow_link( text => 'Upload' );#case sensitive #now on the inventory management page $mech->form_name('form'); # 2 forms on page - other is 'search' # 3 options here - add is incremental $mech->set_fields('delete' => 'add'); $mech->field('upfile' => $upfile ); $mech->click_button(value => 'Upload File'); #the file is uploaded and the status screen displayed here print $mech-> content();
Tk Tartaglia's triangle fun - Pascal's triangle fun
2 direct replies — Read more / Contribute
by Discipulus
on Jun 17, 2014 at 12:56
           Dedicated to my father who studied the other Tartaglia
    After more then one month of sparetime works and 35 subversion i'm very happy to present you:

    16 fun experiments with the Tartaglia's triangle

    This is a Perl Tk program that shows many of the properties of such incredible triangle: you can modify the aspect of the triangle itself and of the output window and of the help pages too.

    In Italy the name of the arithmetic triangle is dedicated Tartaglia so I want to present with this name.

    I'm not a mathematician and the math used in the code is something late Middle Age, but works.

    If someone wish to improve this program i will be very happy: inernal math used, better explication in output windows, or even typos spot(i'm not english native, as you can guess) or suggestion are welcome. In fact i wish this program to be used in educational context.

    Have fun!

    L*


    Update 1/07/2014: commented lines 188-190 and 555 (printing debug info for windows dimensions and positioning).

    L*

    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
Storing Experience for Posterity
4 direct replies — Read more / Contribute
by GotToBTru
on Jun 12, 2014 at 10:34

    I put the following together to scrape experience, level and writeups off my profile page and store it in a text file on my computer, to record my progress through the Monastery. A scheduled task runs this once a day.

    use strict; use warnings; use LWP::Simple; use URI::URL; my $date=`ECHO %DATE:~10,4%%DATE:~4,2%%DATE:~7,2%`; # YYYYMMDD my $url = url('http://perlmonks.org/?node_id=844862'); my $content = get($url); $content =~ s/\cJ//g; $content =~ s/\cM//g; my ($experience, $level, $posts) = ($content =~ /Experience:\D+(\d+).+ Level:.+([A-Z][a-z]+\s+\(\d+\)).+ Writeups:.+>(\d+)</x); open my $ofh, '>>','perl_xp.dat'; printf $ofh "%d,%d,%d,%s\n",$date,$experience,$posts,$level; close($ofh);

    There is probably a way to do this in Javascript that could be included in the Free Nodelet, but that's beyond my skill level.

    Update

    Improved version here.

    1 Peter 4:10
Snoopy Calendar
No replies — Read more | Post response
by timpoiko
on May 18, 2014 at 04:08

    I heard that every real programmer has a Snoopy Calendar dated from 1969. Because Fortran felt slightly uncomfortable for me, I decided to make own version with Perl. In my country first day of week is Monday. You can modify the zeller function if this is a question. This is not obfuscated code, but this code is not written as clearly as possible. Since this code requires some data, at bottom of message there is a link to .tar.bz2. Have fun.

    #!/usr/bin/perl # Copyleft Timo Poikola use strict; my %N; $N{0} = " 000 0 00 00 0 000 "; $N{1} = " 1 11 1 1 11111"; $N{2} = " 222 2 2 2 2 22222"; $N{3} = "33333 3 33 3 3 333 "; $N{4} = " 4 44 4 4 44444 4 "; $N{5} = "555555 5555 55555 "; $N{6} = " 666 6 6666 6 6 666 "; $N{7} = "77777 7 7 7 7 "; $N{8} = " 888 8 8 888 8 8 888 "; $N{9} = " 999 9 9 9999 9 999 "; $N{_} = " "; my @t = localtime(time); my $a = defined $ARGV[0]? $ARGV[0] : $t[5]+1900; my @dim = (undef,31,28,31,30,31,30,31,31,30,31,30,31); sub pn { my $n = shift; my $r = shift; if ($n eq "I") { print " I "; } else { print " "; print substr $N{$n},5*$r,5; print " "; } return $n; } sub zeller { use integer; my $month = shift; my $day = shift; my $year = shift; my $aa = (14 - $month) / 12; my $y = $year - $aa; my $m = $month + 12*$aa - 2; 1+(--$day + $y + $y/4 - $y/100 + $y/400 + (31*$m)/12) %7; } sub lightyear { my $ly = shift; return 1 if (0 == $ly % 4 and 0 != $ly % 100 or 0 == $ly % 400); return 0; } my $text = do { local( @ARGV, $/ ) = "snpdat.txt" ; <> } ; my @str = split //, do {local (@ARGV, $/ ) = "data.txt" ; <> } ; my $ascii = ""; for my $i (0..scalar(@str)/2-1) { $ascii .= $str[2*$i + 1] x unpack("C", $str[2*$i]); } my @art = split(/1/, $ascii); my $d="DAY"; sub label { my $z = shift; $z--; substr $text, $z*553,553; } $dim[2]++ if lightyear($a); for my $cnt (1..13) { my $aux; my $aux2; my $s; my $mm = $cnt; if ($cnt == 13) { $a++; $mm = 1; } $aux = zeller($mm,1,$a); if ($aux > 1) { if ($aux >= 3) { $aux--; $s .= "__I"x$aux; } else { $s .= "__I"; } } for $aux (1..$dim[$mm]) { if ($aux < 10) { $s .="_"; } $s .= $aux; if ((zeller($mm,$aux,$a) == 7) && ($aux < $dim[$mm])) { $s .= "\n"; } elsif ((zeller($mm,$aux,$a) == 7) && ($aux == $dim[$mm])) { $s .= " "; } else { $s .= "I"; } if (($aux == $dim[$mm]) && (zeller($mm,$aux,$a)) < 7) { $aux2 = 7-zeller($mm,$aux,$a); if ($aux2 == 1) { $s .= "__"; } else { $s .= "__I"x($aux2-1); } } } my @arr = split(/\n/, $s); my @l = split(/\n/, label($mm)); print @art[$cnt],"\n\n"; $a =~ /(.)(.)(.)(.)/; print" "x8;pn($2,0);print" "x13,$l[0]," "x13;pn($3,0);print "\n"; print" "x8;pn($2,1);print" "x13,$l[1]," "x13;pn($3,1);print "\n"; print" ";pn($1,0);pn($2,2);print" "x13,$l[2]," "x13;pn($3,2);pn($4,0 +);print"\n"; print" ";pn($1,1);pn($2,3);print" "x13,$l[3]," "x13;pn($3,3);pn($4,1 +);print"\n"; print" ";pn($1,2);pn($2,4);print" "x13,$l[4]," "x13;pn($3,4);pn($4,2 +);print"\n"; print" ";pn($1,3);print" "x20,$l[5]," "x20;pn($4,3);print "\n"; print" ";pn($1,4);print" "x20,$l[6]," "x20;pn($4,4);print "\n\n"; print " "x9,"MON$d"," "x12,"TUES$d"," "x10,"WEDNES$d"," "x9,"THURS$d +"," "x11,"FRI$d"," "x11,"SATUR$d"," "x10,"SUN$d\n"; for (@arr) { print " "," "x20,"I"," I"x5," "x20,"\n"; for my $x (0..4) { print " ";s/(.)/pn($1,$x)/eg;print"\n"; } print " "," "x20,"I"," I"x5," "x20,"\n"; print " ","-"x20,"I","-----------------I"x5,"-"x20,"\n"; } print "\n\n"; }
    http://ig.fi/snoopy.tar.bz2 : Datafiles and source
Tk image resizer
1 direct reply — Read more / Contribute
by Discipulus
on May 05, 2014 at 07:08
    Hello monks,

    was a rainy saturday and i need some resized images for a new website (a Dancer2 one).. but i'm digressing.
    This script globs all jpg images in the current directory and creates one or more resized ones with new names. EXIF data are cleaned in new images whilst you can view some of them, for your convenience, in the preview of the original image.

    Only argouments accepted are string in the form width x heigth x descr as in 1204x768xBig
    You can specify more then one format passing, for example: 1204x768xBig 640x480xMed 200x100xMin
    The description in the string is optional: if not present is used the given ratio: 1204x768 wil be appended to the file name given.

    Using Image::Resize the ratio is maintained for the original photo, ie only the width will be used, while the height will be adjusted as needed.

    The code is redundant and somehow ugly, but Perl does not complains about this..

    HtH
    L*

    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
Indicator Applet by Gtk2-perl of Launcher
No replies — Read more | Post response
by toskanosu
on May 01, 2014 at 13:28

    Hello, everyone.

    Please permit my incorrect or poor english.

    I saw many Indicator Applet for Ubuntu Unity. Almost all Applet-s are made by Python. I do not see Applet by perl, yet. So, i made Indicator Applet by Gtk2-perl of Launcher.

    These are a program and a need file. Please refer for details: http://www.eonet.ne.jp/~toskanosu/

    #! /usr/bin/perl # # Copyright 2014 toskanosu (2014.04.23-05.01 run-perl.pl as /usr/local +/bin/run-perl) # (This is a perl Indicator Applet) (ubuntu Unity libappindicator) # # AUTO menu update is not implemented for Run_Any_File modified, but m +anualy. # use strict; use warnings; use Gtk2 '-init'; use Glib qw/TRUE FALSE/; use English; use utf8; use Encode; use Cwd; use Gtk2::AppIndicator; # libgtk2-appindicator-perl installed by Synap +tic my $HOME=$ENV{"HOME"}; my $USER=$ENV{"USER"}; my $Run_Any_File = $HOME."/.run-any"; # you can change contents in thi +s file. my $Myself_Icon="/usr/share/ubuntu-tweak/pixmaps/emblem-ohno.png"; # y +ou can change as you like. my $White = Gtk2::Gdk::Color->new (0xFFFF,0xFFFF,0xFFFF); my $Red = Gtk2::Gdk::Color->new (0xFFFF,0,0); my (@Head,@Body,@Kind,$AppIndicator,$ImageMenuItem); sub Trim { my $v = shift; $v =~ s/^\s*(.*?)\s*$/$1/; return $v; } sub Left { return substr($ARG[0],0,$ARG[1]); } sub IsIt { return index($ARG[0],$ARG[1]) > -1 } sub Make_About { my $AboutDialog=Gtk2::AboutDialog->new; $AboutDialog->set_program_name('run-perl'); $AboutDialog->set_comments("Indicator Applet made by perl.\n". "Menu Launcher mde by toskanosu."); $AboutDialog->set_website('http://www.eonet.ne.jp/~toskanosu/'); $AboutDialog->signal_connect(response => sub { $AboutDialog->destr +oy }); $AboutDialog->show_all; } sub Get_Kind { my $Body=shift; return(0) if $Body eq ''; my @Line1=split(/\./,$Body); my $Ex=lc($Line1[$#Line1]); my @Line2=split(/ /,$Body); if ($Ex eq 'exe') { return 1 } # sh elsif($Ex eq 'pl') { return 2 } # perl elsif($Ex eq 'rb') { return 8 } # ruby elsif($Ex eq 'py') { return 3 } # python elsif($Ex eq 'sh') { return 4 } # sh elsif(Left($Body,4) eq 'http' || Left($Body,5) eq 'file:') { return 5 } # http or file +: elsif(IsIt($Body,'/') && $#Line2 == 0) { return 6 } # dir else { return 7 } # sh command } sub MenuItem_Clicked { my $Kind=$Kind[$ARG[1]]; return(TRUE) if $Kind == 0; my $Body=$Body[$ARG[1]]; if ($Kind == 2) { system("/usr/bin/perl ".$Body) } elsif($Kind == 8) { system("/usr/bin/ruby ".$Body) } elsif($Kind == 3) { system("/usr/bin/python ".$Body) } elsif($Kind == 5) { system("/usr/bin/xdg-open ".$Body) } elsif($Kind == 6) { system("/usr/bin/nautilus ".$Body) } else { system("/bin/sh -c '".$Body."'") } # 1, 4, 7 FALSE; } sub Set_Image { my $ImageMenuItem=shift; my $Stock_ID=shift; my $Image=Gtk2::Image->new; $Image->set_from_icon_name($Stock_ID,'menu'); # Get icon only! $ImageMenuItem->set_image($Image); $ImageMenuItem->set_always_show_image(TRUE); # Required! } sub Set_Icon { my $Menu=shift; my $Inx=shift; my $Stock_ID=shift; my $ImageMenuItem=Gtk2::ImageMenuItem->new($Head[$Inx]); Set_Image($ImageMenuItem,$Stock_ID); $ImageMenuItem->signal_connect("activate"=> \&MenuItem_Clicked, $I +nx ); $Menu->append($ImageMenuItem); } sub Set_My_Icon { my $Title=shift; my $Stock_ID=shift; $ImageMenuItem=Gtk2::ImageMenuItem->new($Title); my $Image=Gtk2::Image->new_from_stock($Stock_ID,'menu'); # Get ico +n and title $ImageMenuItem->set_image($Image); $ImageMenuItem->set_always_show_image(TRUE); } sub Make_Menu { @Head=(); @Body=(); @Kind=(); # Initialize my $Menu=Gtk2::Menu->new; $AppIndicator->set_menu($Menu); open(File, $Run_Any_File) || die "no file: ".$Run_Any_File; while(<File>) { chomp($ARG); next if Left($ARG,1) eq '#'; # comment next if $ARG eq ''; my @Line=split(/\|/,$ARG); my $Head=Trim($Line[0]); my $Body=$#Line >= 1 ? Trim($Line[1]) : ""; $Body =~ s/\{HOME\}/$HOME/; $Body =~ s/\{USER\}/$USER/; push(@Head,decode_utf8($Head)); push(@Body,$Body); push(@Kind, +Get_Kind($Body)); } close(File); if($#Head > -1) { for (0..$#Head) { if ($Kind[$ARG] == 1) { Set_Icon($Menu,$ARG,'application +-x-executable') } # exe elsif($Kind[$ARG] == 8) { Set_Icon($Menu,$ARG,'application +-x-ruby') } # ruby elsif($Kind[$ARG] == 2) { Set_Icon($Menu,$ARG,'application +-x-perl') } # perl elsif($Kind[$ARG] == 3) { Set_Icon($Menu,$ARG,'text-x-pyth +on') } # python elsif($Kind[$ARG] == 4) { Set_Icon($Menu,$ARG,'application +-x-executable') } # sh elsif($Kind[$ARG] == 5) { Set_Icon($Menu,$ARG,'text-html') + } # http elsif($Kind[$ARG] == 6) { #nautilus if ($Body[$ARG] eq $HOME) { Set_Icon($Menu, +$ARG,'gtk-home') } elsif($Body[$ARG] eq 'computer:///') { Set_Icon($Menu, +$ARG,'computer') } elsif($Body[$ARG] eq 'network:///') { Set_Icon($Menu, +$ARG,'folder-remote') } elsif($Body[$ARG] eq 'trash:///') { Set_Icon($Menu, +$ARG,'user-trash') } else { Set_Icon($Menu, +$ARG,'gtk-directory') } } elsif($Kind[$ARG] == 7) { Set_Icon($Menu,$ARG,'application +-x-executable') } # sh command elsif($Head[$ARG] eq '--TEAROFF--') { $Menu->append(Gtk2::TearoffMenuItem->new); # --------- } elsif($Head[$ARG] eq '--SEPARATOR--') { $Menu->append(Gtk2::SeparatorMenuItem->new); } else { # comment my $MenuItem=Gtk2::MenuItem->new($Head[$ARG]); $Menu-> +append($MenuItem); } } } $Menu->append(Gtk2::SeparatorMenuItem->new); # --------- Set_My_Icon('Refresh','gtk-refresh'); $ImageMenuItem->signal_connect("activate"=> \&Make_Menu); $Menu->append($ImageMenuItem); Set_My_Icon('About','gtk-about'); $ImageMenuItem->signal_connect("activate"=> \&Make_About); $Menu->append($ImageMenuItem); Set_My_Icon('Quit','gtk-quit'); $ImageMenuItem->signal_connect("activate",sub { Gtk2->main_quit; } +); $Menu->append($ImageMenuItem); $Menu->show_all(); } $AppIndicator=Gtk2::AppIndicator->new("Perl_AppIndicator",$Myself_Icon +); $AppIndicator->set_icon_theme_path(getcwd()); Make_Menu(); $AppIndicator->set_active(); Gtk2->main; TRUE; __END__

    The following file includes a japanese kanji. Sorry.

    # # 1st column # is a comment line. # This file is UTF-8 coding for Linux. # Spec by toskanosu. # This file is made in ~/.run-any # PATH end by ".pl" ==> start by perl # PATH end by ".py" ==> start by python # PATH end by ".sh" ==> start by sh (without STDIN) # PATH end by ".exe" ==> start by sh (for wine) # PATH start by "http" ==> start by xdg-open (URI) # no PATH ==> menu displayed (comment) # --SEPARATOR-- ==> Gtk2 separator (-------) # PATH without slash ==> start by sh (without STDIN) # PATH include space ==> start by sh (without STDIN) # else ==> start by xdg-open (folder) # # {HOME} is changed to ~ # {USER} is changed to your user name # # ---LABEL---- | ---PATH------ --------------- important --------------- &#9632; Paster | {HOME}/perlsrc1/paster2sub.pl Run GetTV (runner2) | {HOME}/perlsrc1/runner2.pl GetRSS &#12288;&#12288; | {HOME}/perlsrc1/getrssN1.pl GetTV 1-day &#12288;&#12288; | perl {HOME}/perlsrc1/gettv.p +l 0 Run-Show &#12288; | {HOME}/perlsrc1/runner3x.pl geany ~/.run-any | geany {HOME}/.run-any geany ~/MenuItem.linux | geany {HOME}/MenuItem.linux --------------- Folder --------------- &#12467;&#12531;&#12500;&#12517;&#12540;&#12479;&#12540;&#12288; + | computer:/// perlsrc1 | {HOME}/perlsrc1 pysrc | {HOME}/pysrc Toshi-HP | {HOME}/toshi_hp Free Icon | {HOME}/Hozon1/free-png ubuntu tweak png | /usr/share/ubuntu-tweak/pixmaps --SEPARATOR-- --------------- exec --------------- K-&#23558;&#26827; | wine /media/toshiaki/C-500GB +/K-Shogi/K-Shogi.exe Win&#29992;DLL&#31561; | winetricks XPad | xpad nautilus restart | nautilus -q world watch | gnome-clocks --TEAROFF-- -------------- install-------------- Ubuntu Software Center | software-center Synaptic Package Manager | synaptic-pkexec --------------- setup --------------- Set StartUp | gnome-session-properties ubuntu-tweak | ubuntu-tweak gnome-tweak-tool | gnome-tweak-tool unity-tweak-tool | unity-tweak-tool unsettings | unsettings CompizConfig | ccsm #EOF----------------------------------
read raw mouse data in Linux
No replies — Read more | Post response
by Lotus1
on Apr 30, 2014 at 16:58

    I'm working on a stepper motor project with the Raspberry Pi and I needed to detect when an an optical mouse stops seeing motion. I'm using the mouse in place of an optical encoder to tell me when the stepper is stalled.

    This code works on Raspbian with or without X. Since POSIX::read() waits for mouse events at first I thought I would have to use a second thread to poll somehow. Then I found the alarm function in "Programming Perl".

    I found solutions for reading raw mouse data in Python but of course I wanted to do it in Perl. And I'm sharing it here so others can find it. (The oo Mouse module makes websearches for Perl related mouse projects difficult to find.)

    #!/usr/bin/perl use warnings; use strict; use POSIX; use Time::HiRes qw( ualarm ); ### Detect if the mouse is moving or stopped. Tested on Raspian Linux. ### Adapted from http://www.the-ownage.com/?p=835 ### The guy soldered a pair of wires to a mouse button ### and used it to detect water leaks and send himself notifications. my $fd; my $buf; my $mousedev="/dev/input/mouse0"; $fd = POSIX::open($mousedev, &POSIX::O_RDONLY) or die ("Cannot open $m +ousedev: $!"); my $stopped = 1; print time,"--Mouse is stopped--\n"; while( 1 ) { local $SIG{ALRM} = sub { print time,"--Mouse is stopped--\n" if ! $stopped; #on tra +nsition $stopped = 1; ### turn on output bit on Raspberry Pi $buf =""; }; ualarm 200_000; ## time out after 0.2 seconds POSIX::read($fd, $buf, 1); if ( $buf and $stopped ) { print time,"--Mouse is moving--\n"; $stopped = 0; ### turn off output } ualarm 0; }
Substitution cipher or keyboard layout demo
1 direct reply — Read more / Contribute
by ohcamacj
on Apr 27, 2014 at 00:02

    As a longtime dvorak user, I've occassionally noticed that it's extremely unbalanced left-right. The right hand, does almost all of the work.

    A few times, I've tried using xmodmap to create a mirrored keyboard layout; but this didn't work well. Since my typing speed falls 10x, it's always faster to just leave the keyboard layout untouched.

    Wasn't there some way to practice a new keyboard layout, without constantly running

    setxkbmap -layout dvorak -option ctrl:nocaps; xmodmap new-layout; setxkbmap -layout dvorak -option ctrl:nocaps; xmodmap ~/.xmodmaprc
    to switch back and forth ?

    So, wrote a perl script, to apply what-if-the-keyboard was a different layout transform to input.

    That alone wouldn't be interesting enough to post. A trivial one-liner with s/./$map{$&} ? $map{$&} : $&/eg; is sufficient.

    But, it was sorta clumsy to use. In a shell, a lot of keystrokes are necessary (up-arrow, backspace, backspace, backspace) to change the text. So, I eventually wrote a terminal ui for it, to make it easier to use.

    The code

    Dvorak keyboard users are rare, people who are trying to become left-handed are extremely rare. So, change $leftside and $rightside to something else, more meaningful.

Perl Script to extract host list from Symmetrix DMX Array.
No replies — Read more | Post response
by pmu
on Apr 18, 2014 at 15:43

    Hi,

    As an Storage Administrator who works on EMC Symmetrix Storage Array, many times, I have to extract a list of all the hosts connected to the storage array. This needs to be extracted by logging into the storage array and running a command like symmask -sid 12345 list logins, and then the hostnames are to be extracted from the list and stored in a text file. If hostnames are not reflecting, then the corresponding World Wide Name (WWN) of the Host HBA should be included in the list. To ensure dual or quadruple redunduncy, each host will show two paths or four paths, so the duplicates need to be removed and the host names need to be in Upper case. There are many such arrays, and a seperate file needs to be created for each of them.

    Sometimes, the file has to be regenerated every few minutes due to some changes/requirements and the old file must be deleted, else wrong records will be captured. The script picks the array name from the command output stated earlier. This script is working fine on Redhat Linux 6.4 running Perl Version 5.10.1 and on Windows 2003 running Strawberry Perl version 5.18.2.2.

    Hoping fellow EMC Administrators will find this script useful. Please note - I dont get to write scripts on a regular basis, so there's quite a lot of improvement that can be done with the script. If so, kindly let me know. Here's the script:

    Here's the test file that's fed to the script. The actual file will have much more entries than what's given below.

    And here is the output:

    C:\Users\pmu\Documents\perl\work>perl hostnames.pl test_list_logins.tx +t Deleting existing "hostlist_hostnames.pl_000190101234.txt". A new one +will be created. ********************************************************************** +******************* Please Check the file - [ C:\Users\pmu\Documents\perl\work\hostlist_ho +stnames.pl_000190101234.txt ]. NULLs are replaced with corresponding pWWNs. ********************************************************************** +******************* C:\Users\pmu\Documents\perl\work

    And here's what the file - hostlist_hostnames.pl_000190101234.txt contains:

    -------------------------------------------------------------- Perspectum cognitio aeterna --------------------------------------------------------------

Add your CUFP
Title:
CUFP:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others chilling in the Monastery: (13)
    As of 2014-07-31 17:32 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      My favorite superfluous repetitious redundant duplicative phrase is:









      Results (249 votes), past polls