Beefy Boxes and Bandwidth Generously Provided by pair Networks RobOMonk
Don't ask to ask, just ask
 
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
efficient determination of in/out of hours including Bank Holidays
1 direct reply — Read more / Contribute
by Random_Walk
on Oct 17, 2013 at 06:10

    Hello dear monks, fair and foul

    I have a monitoring alert gateway. It must invoke different behaviours in working hours and out of hours. Sometimes it may be asked to forward 1000/sec. Rather than run a test for in/out of hours on each event, I decided to have a flag for ooh, and a record of the epoch time when the next change will happen. This way, most of the time I just check the flag and its validity. Only a couple of times a day, do I need to work out if its in hours, weekend, bank holiday, etc.

    This script builds a closure which knows the bank hols and working hours. When it is invoked with an epoch time, it will return a flag for out of hours, and the epoch time until which this is valid.

    There is a minor inefficiency when Monday is a holiday. At the end of Friday it will return Mondays start time as the limit of validity for the OOH flag. This is not a big problem, as when it is called then to find the next validity point, it will see it is in a bank holiday and act accordingly

    All suggestions/comments/improvements/missed corner cases welcome

    Update

    soonix++ for spotting a problem. There were timezone issues with the bank holiday code (see following thread). This version should have fixed them, the original version is left below. I have also made working days a parameter, I am aware we don't all work mon..fri

    Update 2

    I have also added correction for when the valid until time falls across a daylight savings time boundary.

    #!/usr/bin/perl use strict; use warnings; use POSIX qw(mktime); use Data::Dumper; use 5.014; sub ooh { my $start = shift; my $end = shift; my %wkwk = map {$_ => 1} @_; my @start = reverse split /:/, $start; # deliciously my @end = reverse split /:/, $end; # naughty my $i; my %mns=map{$_=>$i++}qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct No +v Dec); # Bank holidays # We assume they all begin at 00:00:00 and encompas the entire day # POSIX::mktime(15, 28, 06, 27, 02, 206);' my @bh; my $today = join ":", reverse +(localtime time)[3 .. 5]; while (<DATA>) { # read bank holiday file next unless /\d\d?\s+\w\w\w\s+\d{4}/; chomp; my ($day, $month, $year) = split; my $bh_start = join ":", $year-1900, $mns{$month}, $day; next if $bh_start lt $today; # history push @bh, $bh_start; } @bh = sort @bh; return sub { my $epoch = shift; my ($s, $m, $h, $date, $mnth, $yr, $day) = +(localtime $epoch) +[0 .. 6]; # Check if we are out of hours, and when next flip is due my ($valid, $ooh); if ("$yr:$mnth:$date" eq $bh[0]) { # hooray! bank holiday shift @bh; # rip page from calendar $ooh = 1; print "Bank Holiday "; } if (not $ooh and $wkwk{$day}) { # not a bank hol, is a working + day my $time = sprintf "%02d:%02d:%02d", $h,$m,$s; if ($time lt $start) { # not out of bed yet print "Early doors "; $valid = POSIX::mktime(@start, $date, $mnth, $yr); $ooh = 1; } elsif ($time lt $end) { # came in, dreaming of home print "Working hours "; $valid = POSIX::mktime(@end, $date, $mnth, $yr); $ooh = 0; } else { print "G'night "; } } else { print "Weekend " unless $ooh; } unless ($valid) { # we did not establish our validity limit ye +t # we are at end of day, weekend or hols. Find next working + day my $add = 1; ++$add until $wkwk{($day + $add)%7}; print "next working day is " .($day + $add)%7 . " "; $valid = POSIX::mktime(@start, $date, $mnth, $yr); $valid += $add * (24*60*60); # Daylight savings adjustment my $dst = $start[2] - +(localtime $valid)[2]; $valid += $dst * 60 * 60; $ooh = 1 } return $ooh, $valid; } } # get an ooh tester, work week mon..fri my $ooh_check = ooh('08:15:00', '17:45:00', 1..5); # and run some tests for (sort (time, 1382310123, 1359806999, 1360306452, 1381941000, 1360016452, 1382823512)) { my ($ooh, $valid) = $ooh_check->($_); say join " - ", scalar localtime $_, $ooh, scalar localtime $valid +; } __DATA__ 02 Feb 2013 18 Oct 2013 21 Oct 2013 23 Oct 2013

    This is the original, broken version

    use strict; use warnings; use POSIX qw(strftime mktime); use Data::Dumper; sub ooh { my $start = shift; my $end = shift; my %wkwk = map {$_ => 1} (1..5); # Mon .. Fri my $i; my %mns = map{$_=>$i++}qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct +Nov Dec); # Bank holidays # We assume they all begin at 00:00:00 and encompas the entire day # POSIX::mktime(15, 28, 06, 27, 02, 206);' my @bh; while (<DATA>) { # read bank holiday file next unless /\d\d?\s+\w\w\w\s+\d{4}/; chomp; my ($day, $month, $year) = split; my $mnth = $mns{$month}; my $bh_start = POSIX::mktime(00, 00, 00, $day, $mnth, $year - +1900); next if $bh_start < time; # history push @bh, $bh_start; } @bh = sort @bh; return sub { my $epoch = shift; my ($s, $m, $h, $date, $mnth, $yr, $day) = +(localtime $epoch) +[0 .. 6]; print $/; print scalar localtime $epoch; # Check if we are out of hours, and when next flip is due my $valid; my $ooh; if ($epoch > $bh[0]) { # its a new bank holiday shift @bh; # rip this page from the calendar $ooh = 1; print " Bank Holiday"; } if (not $ooh and $wkwk{$day}) { # not a bank hol, is a working + day my $time = sprintf "%02d:%02d:%02d", $h,$m,$s; print " given: $time "; if ($time lt $start) { # not out of bed yet print "early doors "; ($h, $m, $s) = split /:/, $start; $valid = POSIX::mktime($s, $m, $h, $date, $mnth, $yr); return 1, $valid; } elsif ($time lt $end) { # came in, dreaming of home print "within working hours "; ($h, $m, $s) = split /:/, $end; $valid = POSIX::mktime($s, $m, $h, $date, $mnth, $yr); return 0, $valid; } else { print "g'night"; } } else { print " weekend" unless $ooh; } # find next working day my $add = 1; ++$add until $wkwk{($day + $add)%7}; print " Next working day is " .($day + $add)%7 . " "; # end of day, weekend or hols ($h, $m, $s) = split /:/, $start; $valid = POSIX::mktime($s, $m, $h, $date, $mnth, $yr); $valid+= $add * (24*60*60); return 1, $valid; } } # get an ooh tester my $ooh_check = ooh('08:15:00', '17:45:00'); # and run some tests print join " -> ", 'OOH', $ooh_check->(1382310123); print join " -> ", 'OOH', $ooh_check->(1359806999); print join " -> ", 'OOH', $ooh_check->(1360306452); print join " -> ", 'OOH', $ooh_check->(1381941000); print join " -> ", 'OOH', $ooh_check->(1360016452); print join " -> ", 'OOH', $ooh_check->(time); __DATA__ 01 Jan 2012 02 Feb 2013 03 Feb 2014 04 Aug 2013 21 Oct 2013

    Cheers,
    R.

    Pereant, qui ante nos nostra dixerunt!
Rough/Simple auth.log Analysis
1 direct reply — Read more / Contribute
by wjw
on Oct 04, 2013 at 06:59
    Warning: may be cool only to me...

    What it is

    I recently noticed that my auth.log file seemed fairly large for a server which (should have) no real value to anyone other than me. Taking a gander at it showed that someone had been trying to ssh into it about every 3 seconds for a fair stretch of time. This sort of irritated me. Having been away from Perl for a while, I figured I could brush up a bit on something fairly basic as well as give myself a tool to satisfy my curiosity about these idiots that are trying so hard to break into something with no real $$ related content. I am presenting it here because I have not posted here before, and thought that maybe someone else might find it useful.

    Basics

    There are three parts to the tool:
    1. auth_examine.pl - examines the current auth.log file looking for a regex match and stores some info about that log entry. It is run once an hour by root:cron on my system
    2. auth_log_analysis.sqlite3 stores info gathered by auth_examine.pl, and of course retrieves said info
    3. auth_log_report.cgi sends some queries to auth_log_analysis.sqlite3 and build some very simple tables that are reasonably informative and easy to read

    Resources Used

    Perl 5.18 and Sqlite3 on Ubuntu 13.04

    Additionally I used the following modules:

    • DBI
    • DBD::SQLite
    • Date::Calc qw(:all :Date_to_Time)
    • DateTime
    • CGI qw(:all)
    • Net::Whois::IP qw(whoisip_query)
    • DateTime::HiRes
    • File::Util
    • Log::Log4perl qw(get_logger)
    Admittedly, I barely used any of them as this was mostly an exercise to refresh my memory

    Wandering Thoughts

    This is running on my machine currently so I guess one could say it has been tested in one environment.

    I read the whole auth.log file into an array then trim the array down using splice based on info stored in the DB. I do this for a couple of reasons:

    • my auth.log is relatively small
    • I am not paying attention to whether auth.log is busy at the moment or not, so I try to not leave it hanging open
    • I am used to doing it that way when I know the file is not going to wipe out my entire memory resource

    I did not go out of my way on comments and there is no POD either. It is written in such a way that between log4perl and perl -d anyone should be able to figure out what is going on.

    Anyone using it will have to ensure that sane(for their system) paths are supplied in the code(no nice config file, sorry).

    I am Tempted..

    ..to extend the tool to auto-update my iptables and then auto send an email to the who-is result, though I know the IP is probably spoofed

    At any rate, following is the tool, rough, ugly and working should you be interested...

    auth_examine.pl ->


    auth_log_report.cgi ->
    auth_log_analysis.sqlite3 ->
    • ...the majority is always wrong, and always the last to know about it...
    • ..by my will, and by will alone.. I set my mind in motion
Generate a single "or regex" from given strings
3 direct replies — Read more / Contribute
by Anonymous Monk
on Sep 27, 2013 at 10:51

    I got tired of remaking regex (of email addresses) for use by procmail and mutt by hand. Then I wrote the following. The worst case is every string is simply joined, which is still better than manual operation. Ideally one of three modules -- Regexp::(Assemble|Optimizer|Trie) -- will be used to generate the regex when available.

    Mind that ...

    • /i flag is used; feel free to make it optional yourself;
    • duplicates in input are not considered;
    • end-spaces are removed.
    #!perl use strict; use warnings; our $VERSION = '0.07'; # or-re.pl - Given a list of strings, prints a OR'd regex; prints tes +t results # for the input. # # End-spaces & duplicate strings are removed before generating the re +gex. scalar @ARGV or die qq[Give strings to make one "or" regex.\n]; my @list = prepare( @ARGV ); my $re = build_re( @list ); printf "Regex...\n %s\n\n" , $re; re_test( $re , @list ); exit; sub re_test { my ( $re , @list ) = @_; ref $re or $re = qr/$re/; print "Test ...\n"; for my $it ( @list ) { printf " %s %14s\n" , $it , ( $it =~ $re ? 'matches' : 'does NOT match' ) ; } return; } sub prepare { scalar @_ or return; my %seen; return map { s/^\s+//; s/\s+$//; !$seen{ $_ }++ ? $_ : () } @_; } sub build_re { scalar @_ or return ''; my @arg = @_; my %mod_map = ( 'Regexp::Assemble' => \&via_assemble , 'Regexp::Optimizer' => \&via_optimizer , 'Regexp::Trie' => \&via_trie , 'mine' => sub { return decorate( simpleton( @_ ) ) +} ); my @order = ( 'Regexp::Assemble' , 'Regexp::Optimizer' , 'Regexp::Trie' ); my $maker = 'mine'; for my $mod ( @order ) { _load_module( $mod ) or next; $maker = $mod; last; } return $mod_map{ $maker }->( @arg ) } sub decorate { return qq/\\b(?i:$_[0])\\b/ ; } sub simpleton { return join '|' , map { quotemeta( $_ ) } sort { length $b <=> length $a || lc $a cmp lc $b } @_ ; } sub via_assemble { my $maker = Regexp::Assemble->new( 'chomp' => 1 , 'reduce' => 1 , 'modifiers' => 'i' , 'anchor_word' => 1 ); $maker->add( map quotemeta( $_ ) , @_ ); # R:A::as_string() method eschews flags given. This preserves it at +the cost # of extraneous syntax elsewhere. return $maker->re() . ''; } sub via_optimizer { my $re = simpleton( @_ ); my $maker = Regexp::Optimizer->new(); return $maker->as_string( qr/\b(?:$re)\b/i ); } sub via_trie { my $maker = Regexp::Trie->new(); # Cannot add as list, unlike R::Assemble. $maker->add( $_ ) for @_; return $maker->regexp() . ''; } sub _load_module { my ( $mod ) = @_; local $@; eval qq/ require $mod; 1; /; $@ and do { warn "Could not load $mod: $@\n"; return; }; warn "# Using $mod ...\n"; return 1; }
exports -- which module exports are used?
4 direct replies — Read more / Contribute
by tye
on Sep 16, 2013 at 12:26
    use POSIX;

    I hate that line of code. It imports over 500 symbols, the vast majority of which surely aren't being used. But the real crime is the bad documentation it provides.

    use POSIX qw< ceil floor >;

    That is a reasonable line of Perl code. Now, when somebody is reading the file of code that contains it and runs across "floor( ... )", they don't have to rely on having memorized even a tiny fraction of the hundreds of possible exports from POSIX.pm in order to figure out that "perldoc POSIX" will tell them what floor() does.

    And, if they find that 'floor' and 'ceil' (and 'POSIX') are not mentioned anywhere else in the code, then they can remove the whole "use POSIX" line. That can be important information when refactoring code.

    So, when I run into "use POSIX;" in code, what do I do about it? I want to replace it with a line that makes the exports explicit. But searching through several hundred lines of code for usages of any of hundreds of symbols is beyond my abilities. So I wrote a simple Perl script:

    > exports Usage: exports [-a] [ Perl::Module [...] ] [ file [...] ] Writes out what each listed module by-default exports or reports all uses of those exports in the listed files. If no module names are listed, then searches each file for cases of 'use Perl::Module;' and suggests replacements. -a: Searches for *any* exports, not just default ones.
    > grep POSIX ASAP/Client.pm ASAP/Client.pm:use POSIX;
    > exports POSIX ASAP/Client.pm ASAP/Client.pm: 107: strftime("%Y-%m-%dT%T$fs Z", gmtime($sec)); strftime # use POSIX qw< strftime >;

    Now I can replace that horrible line of code with the suggested reasonable line of code!

    Of course, POSIX.pm is not the only module that has default exports. The real useful mode for exports is to just give it a list of file names:

    > exports bin/mktestcalls bin/mktestcalls: 1197: openlog( 'mktestcalls', 'pid', 'local3' ); openlog 1204: GetOptions(\%opt, GetOptions 1237: -H pretend to be hostname hostname 1293: my $HOSTNAME = $opt{H} || hostname(); hostname 1590: out_server => hostname(), hostname 2229: eval{ syslog( 'debug', $msg ) }; syslog # use Asterisk::AGI(); # No default exports # use Socket(); # Not used? # use Sys::Hostname qw< hostname >; # use Sys::Syslog qw< openlog syslog >; # use Getopt::Long qw< GetOptions >;

    Which gives me nice replacements for much of:

    > grep use bin/mktestcalls use strict; use Asterisk::AGI; use List::Util 'shuffle'; use Socket; use Sys::Hostname; use Sys::Syslog; use Sys::SigAction 'set_sig_handler'; use Getopt::Long;

    If you have made changes to some code and now you aren't sure if the "use List::Util qw< shuffle max >;" line is still accurate, then you just use exports' "-a" option:

    > exports -a List::Util lib/Track.pm lib/Track.pm: 1768: push @dial_servers, shuffle(@servers); shuffle 1820: $maxto = max( max 1821: min( min 1867: # S() = max call duration in seconds max # use List::Util qw< max min shuffle >;

    There are also several other ways to use this script. You can just give it a list of module names and it will tell you what they export by default:

    > exports File::Basename File::Glob File::Basename 2.78: fileparse fileparse_set_fstype basename dirname File::Glob 1.07:

    Or what they can export explicitly:

    '-' causes STDIN to be read. Also, all module names must come before any file names.

    Lastly, it gives a very nice, short example of the output that you get. You get the file name followed by each line of code from that file where an export is mentioned. Each of those lines is underscored (with a repeat of any exports) to highlight each export. Then you get comment lines showing how you should probably import from each module. This pattern of output repeats for each file.

    - tye        

strictv -- how unstrict is your code?
1 direct reply — Read more / Contribute
by toolic
on Sep 05, 2013 at 11:03
    Time and again I inherit code which does not use strict and warnings. One of the first things I do is turn on strict to see how much work lies ahead for me to make it strict. If I'm lucky, I just get a few complaints. More typically, however, I get screens full of output scrolling by. This will give you a short summary of the variables instead of the normal verbose strict output. For example:
    $ strictv fool.pl $card : 3 $cardcounter : 2 $count : 2 $counter : 3 $i : 5 $number : 2 $suit : 2 $types : 2 @alreadyused : 2 @cards : 6 @iterations : 2 @suit : 2 foo.pl: 12 variables

    It's also handy for code that people post on PerlMonks.

    =head1 NAME B<strictv> - How (un)strict is your Perl code? =head1 SYNOPSIS strictv file ... =head1 DESCRIPTION Compile (but do not run) a Perl file using the C<strict> pragma. Only variables are checked. Input is a file (or several files). Output is to STDOUT. Example: strictv foo.pl =cut use warnings FATAL => 'all'; use strict; use List::Util qw(max); use English qw(-no_match_vars); for my $file (@ARGV) { $CHILD_ERROR = 0; my @errs = qx(perl -Mstrict=vars -c $file 2>&1); if ($CHILD_ERROR) { my %var; for (@errs) { if (/open perl script/) { print; } elsif (/ "([^"]+)" /x) { $var{$1}++; } } if (%var) { my $width = max(map {length} keys %var); for my $name (sort keys %var) { printf " %-${width}s : %d\n", $name, $var{$name}; } print "$file: ", scalar(keys %var), " variables\n"; } } }
Mojolicious::Lite +and jQuery +AJAX + Mojo::Template
No replies — Read more | Post response
by Anonymous Monk
on Aug 29, 2013 at 05:26

    Mojolicious comes with jquery2.x, here is how you can use it

    docs

    code is single file( moquery.pl ), subroutines above , static files and templates in __DATA__; The template language is simple, its regular perl %= time() or  <%= rand(time) %>

    to run this

    perl moquery.pl daemon perl moquery.pl daemon --mode=production -l http://localhost:80
    and fireup your browser to http://localhost:3000 or http://localhost:80, click the buttons/links and watch the visual changes. Note how get/ing /error is a 404

    All praise be to all the innovators and to everybody :) thanks all

Visualize a XML Document as a Tree
No replies — Read more | Post response
by choroba
on Aug 26, 2013 at 07:16
    Some of you might have experienced it, too. You work with an XML document whose structure is complicated. Constructing XPath queries becomes boring at last, even in an interactive XML processing tool like XML::XSH2. A diagram would help.

    Here is a short xsh script that creates a dot source code. Just pipe its output to dot to get a nice graphical representation of the XML structure!

    Example usage:

    xsh -al xml2dot.xsh data.xml | dot -Tpng > data.png
    لսႽ ᥲᥒ⚪⟊Ⴙᘓᖇ Ꮅᘓᖇ⎱ Ⴙᥲ𝇋ƙᘓᖇ
Simple example of CGI (Perl) + HTML + CSS + Javascript/jQuery + Ajax
1 direct reply — Read more / Contribute
by golux
on Aug 21, 2013 at 12:23
    Questions about combining Perl with jQuery keep coming up, so I'm posting this simple example to be able to refer to it later.

    Update:   You can see a running example of the code here. What it does -- displays a grid of numbers, letting you click on any number to see its factors, and tells whether the number is prime or composite. You can also click on the button "Server Info" to invoke the Ajax code which shows the local time of the server.

    Update 2:   If you add the line var J = jQuery.noConflict(); to the top of the file "pm.js", it will let you change every '$' in the file to 'J'. I usually do that, especially when generating the jQuery/Javascript code directly from the CGI script, as it doesn't force me to escape '$' everywhere.

    Here is the CGI (ie. Perl) code "pm.cgi" which runs on the server:

    #!/usr/bin/perl -w # # Simple jQuery example to demonstrate: # # CGI (Perl) + HTML + CSS + Javascript/jQuery + Ajax # # 2013-08-21 golux ## ############### ## Libraries ## ############### use strict; use warnings; use CGI qw{ :standard }; use CGI::Carp qw{ fatalsToBrowser }; ################## ## User-defined ## ################## my $jquery = "//ajax.googleapis.com/ajax/libs/jquery/1.9.1/jquery.min. +js"; my $max = 625; my $ncols = 25; ################## ## Main program ## ################## server_side_ajax(); print_page_header(); print_html_head_section(); print_html_body_section(); ################# ## Subroutines ## ################# sub print_page_header { # Print the HTML header (don't forget TWO newlines!) print "Content-type: text/html\n\n"; } sub print_html_head_section { # Include stylesheet 'pm.css', jQuery library, # and javascript 'pm.js' in the <head> of the HTML. ## print "<head>\n"; print "<link rel='stylesheet' type='text/css' href='pm.css'>\n"; print "<script src='$jquery' type='text/javascript'></script>\n"; print "<script src='pm.js' type='text/javascript'></script>\n"; print "</head>\n"; } sub print_html_body_section { # Create HTML body and show values from 1 - $max ($ncols per row) print "<body>\n"; print "<center>\n"; print "<h1>Click any number to see its factors</h1>\n"; print qq{ <input type="button" value="Server info" onclick="ajax_info()" +> <span id="info"></span><hr> }; print qq{<div id="result"></div><br>\n}; print "<table width='50%'>"; for (my $i = 0; $i < $max; $i++) { (0 == $i % $ncols) and print "<tr>\n"; my $num = $i + 1; my $onclick = qq{onclick="show_factors($num)"}; print qq{<td id="N$num" class="normal data" $onclick>$num\n}; } print "</table>"; print "</center>\n"; print "</body>\n"; } sub server_side_ajax { my $mode = param('mode') || ""; ($mode eq 'info') or return; # If we get here, it's because we were called with 'mode=info' # in the HTML request (via the ajax function 'ajax_info()'). ## print "Content-type: text/html\n\n"; # Never forget the header! my $ltime = localtime(); print "Server local time is $ltime"; exit; }

    This is the CSS stylesheet "pm.css":

    body { background: #ffcfff; font-family: arial; } .data { border: 1px solid black; text-align: center; cursor: pointer; min-width: 32px; min-height: 32px; width: 32px; height: 32px; } .normal { background: lightgreen; } .composite { background: #3366ff; } .prime { background: deeppink; } .factor { background: yellow; }

    And this is the javascript code "pm.js" which the server downloads to the client (in the HTML page created by "pm.cgi"):
    // // Note: adding the line: // // var J = jQuery.noConflict(); // // lets you change '$' everywhere in this file to 'J'. // function show_factors(num) { // First reset all data $('.data').each(function() { $("#"+this.id).attr('class', 'normal data'); }); // Then find and show all the factors var nfactors = 0; var factors = ""; for (var i = 1; i < num; i++) { if (0 == num % i) { ++nfactors; if (factors) factors += ", "; factors += i; var tag = "#N" + i; $(tag).removeClass('normal').addClass('factor'); } } // Highlight chosen square with class 'prime' or 'composite' var b_prime = (nfactors > 1)? false: true; var newclass = (b_prime)? 'prime': 'composite'; var tag = "#N" + num; $(tag).removeClass('normal').addClass(newclass); // Finally, explain the results var text; if (1 == num) { text = "The number 1 is neither prime nor composite"; } else if (b_prime) { text = "The number " + num + " is prime"; text += " (Its only factors are 1 and itself)."; } else { text = "The number " + num + " is composite."; text += " It has " + nfactors + " factors besides itself: " + + factors; } $('#result').html(text); } function ajax_info() { $.ajax({ url: "pm.cgi", cache: false, dataType: "text", data: { mode: 'info' }, success: function(result) { ajax_info_result(result); } }); } function ajax_info_result(result) { var text = "The server says: <b>" + result + "</b>"; $('#info').html(text); }
    say  substr+lc crypt(qw $i3 SI$),4,5
One liner to print a file system tree on UNIX like systems
2 direct replies — Read more / Contribute
by ciderpunx
on Aug 21, 2013 at 09:08
    I just had occasion to type this and thought I'd share (fairly sure someone will have done this before, but my search-fu fails me).
    ls -R | perl -ne 'if(/:$/){s/:$//;s/[^\/]*\//--/g;s/^-/\t|/;print}'
    Result:
    $ ls -R | perl -ne 'if(/:$/){s/:$//;s/[^\/]*\//--/g;s/^-/\t|/;print}' |---branches |---hooks |---info |---logs |-----refs |-------heads |-------remotes |---------origin |---objects |-----02 |-----0a |-----10 |-----24 |-----27 |-----3f |-----41 |-----4e |-----64 |-----69 |-----6e |-----70 |-----74 |-----76 |-----7b |-----82 |-----8d |-----94 |-----a7 |-----ac |-----b0 |-----b7 |-----d6 |-----dd |-----e2 |-----info |-----pack |---refs |-----heads |-----remotes |-------origin |-----tags |-Spider |---Muffet |-----Filter |-------Reader |-----Output |-------Writer


Utility to calculate best way to archive Dir to DVD
3 direct replies — Read more / Contribute
by slugman
on Aug 02, 2013 at 10:19

    So, I made a utility to help me backup some data I found on my old hard drive. I hadn't seen this stuff in 10 years, and since I've lost backups along the way I didn't want to pass up the opportunity to backup my precious data. Also, since this drive is only 40G, its feasible to backup to 8 or 9 DVDs.

    So basically, you launch the script, and tell it in order:

    ARGV0 - directory to perform calculations on. ARGV1 - Size to output data, KB or MB. ARGV2 - wether you want size stats on directories or just output. ARGV3 - A single directory to skip or several directories. Several directories must be comma seperated with no spaces in between.

    Features I would like to add: a pod style help document which explains how to use this. Also, I would like to be able to dynamically switch between the arguments, so they don't have to be in a particular order (thats how most *nix utilities work, with a few exceptions like mount and stuff.. right?).

    #!/usr/bin/perl # # # # DVD_DIR_SUM # # This script will find the size of all the directories in # the given master directory, and provide the appropriate # directories which will fit inside a sandard DVD. # Diego Z Pineda # dzpineda86@gmail.com # July 22, 2013 use strict; use warnings; sub nl () { print "\n"; print "\n" } my $in_dir = $ARGV[0]; my $units = $ARGV[1]; my $skip = $ARGV[3]; my $skpdr = "$in_dir/$skip"; my @sks; if ($units !~ m{(K|M)B}i ) { print 'Please use appropriate units KB or MB for 2nd argument.'; nl; exit } my $dvd_s; if ($units =~ m{KB}) { $dvd_s = 4699999 } elsif ($units =~ m{MB}) { $dvd_s = 4699 } my @num = qx[du -B $units -d 1 $in_dir | cut -f 1]; my @dir = qx[du -B $units -d 1 $in_dir | cut -f 2]; my @dig; my @vdr; my $sum = 0; my $pre_elm; my $ni = $#num; my $in = $ni + 1; my $si; if ($skip =~ m{,}) { @sks = split(',', "$skip"); $si = $#sks + 1; for (my $i = 0; $i < $in; $i++) { for (my $j = 0; $j < $si; $j++) { if ($dir[$i] =~ m{$sks[$j]}) { $num[$i] = 0 }}}} elsif ($skip !~ m{,}) { for (my $i = 0; $i < $in; $i++) { if ($dir[$i] =~ m{$skip}) { $num[$i] = 0 }}} else { print "$skip is not a directory. Please ensure $skip is a dir i +nside $in_dir." } my $str1 = 'Last directory to load is:'; my $str2 = 'Total DVD size is:'; my $str3 = 'Root directory is:'; my $str4 = 'Skipped the following directories'; pop @num; pop @dir; nl; for (my $i = 0; $i < $in; $i++ ) { my $temp = $num[$i]; if ($units =~ m{KB}) { $units =~ s{KB}{kB}g } $temp =~ s{$units}{}g; $temp =~ s{ $}{}g; chomp $temp; push @dig, $temp } for (my $i = 0; $i < $in; $i++ ) { my $temp = $dir[$i]; $temp =~ s{$in_dir/}{}g; chomp $temp; push @vdr, $temp } for (my $i = 0; $i < $in; $i++) { if ($sum < $dvd_s) { $sum = $sum + $dig[$i]; $pre_elm = $i }} my $tru_sum = $sum - $dig[$pre_elm]; my $tru_elm = $pre_elm - 1; my $tru_dir = $vdr[$tru_elm]; if ($ARGV[2] =~ m{yes|y}i) { print "$str3\t$in_dir"; nl; for (my $i=0; $i < $tru_elm; $i++) { print "$dig[$i] $units\t\t$vdr[$i]"; nl }} print "$str1\t$tru_dir"; nl; print "$str2\t$tru_sum $units"; nl; if ($skip !~ "" && $skip !~ m{,}) { print "$str4:\t\t$skip"; nl } elsif ($si > 0) { print "$str4:"; for (my $i = 0; $i < $si; $i++) { my $i2 = $i + 1; nl; print "$i2\t\t$sks[$i]" }}
Playlist parser for mpg123
1 direct reply — Read more / Contribute
by slugman
on Aug 02, 2013 at 09:48

    I know mpg123 has the ability to play files according to a playlist, however after reading the manpage I wasn't ever really able to figure it out. I became fed up with have to play my songs individually one after the other in the terminal, and when my mpg123 * became insufficient I decided to write something that would achieve playlist parsing.

    So, I wrote Music_System. Yes, I know its misleading, since it doesn't actually play anything. Really, it just uses regex to parse a text file and plays the files accordingly. Then, it uses the find utility to find the appropriate files and plays them accordingly via mpg123.

    To do list: Long Term: a. I just recently discovered the SDL library modules on cpan. I would like to use the audio player to make this an independant audio player capable of playing more than mpeg layers 1, 2, and 3 -- mpg123's primary purpose. Short Term: a. Now that I have mastered ARGV use, I will make use of arguments to be able to specify the music directory to search in, as opposed to hardcoding it as I have currently done. I can implement this easily, and should have that done in a day or two. b. Also, when I used windows I was hooked on foobar2000. I really liked the internal DB it created to sort your music through. Now, I know plenty of players already do this, but I think it would make a good experiment to be able to parse the directory and create an internal hash db based off of the tags. Not quite sure how I'll accomplish this though, since the tags will have to be multi-dimensional. May just stick to multi dimensional arrays. This was posted for my friends to review, and also for dams at Insomnia (to prove I am actually doing something :p ).

    Please don't laugh!

    #!/usr/bin/perl # # # Music System # Diego Z Pineda # July 2013 # dzpineda86@gmail.com use strict; use warnings; sub nl () { print "\n"; print "\n" } sub clrw { chomp $_[0]; $_[0] =~ s/ +$// } my $file = $ARGV[0]; open (my $in, "<", "$file") or die "Can't open input-file: $!"; my @array_in; my @array_out; my @dpath; while (<$in>) { push @array_in, $_ } my $aii = $#array_in; my $iai = $aii + 1; for (my $i=0; $i<$iai; $i++) { my $t1 = "$array_in[$i]"; if ($t1 =~ s/^\# [0-9]+. //) { chomp $t1; $t1 =~ s/ $//; push @array_out, $t1 }} # chopmping all elements being pushed to array_out # will allow shell command to be evaluated. my $aoi = $#array_out; my $iao = $aoi + 1; my $p_dir = '/home/slug/Music'; my $m_dir; my $m_dir_pre = "$array_in[1]"; if ($m_dir_pre =~ s/^\# //) { $m_dir = $m_dir_pre } my $dir = "$p_dir/$m_dir"; clrw $dir; for (my $i=0; $i<$iao; $i++) { my $t1 = qx[find $dir -iname "*$array_out[$i].mp3*"]; chomp $t1; if ($t1 =~ m/\n/) { chomp $t1; my ($s1, $s2) = split('\n', "$t1"); clrw $s1; clrw $s2; push @dpath, $s1; push @dpath, $s2 } else { clrw $t1; push @dpath, $t1 }} my $dpi = $#dpath; my $idp = $dpi + 1; for (my $i=0; $i<$idp; $i++) { my $prog = 'mpg123'; my @args = ("$prog", '--cpu', 'SSE', "$dpath[$i]"); system(@args) == 0 or die "System args failed: $?" }

    So, you take a playlist made with your favorite editor (mine is vim), and follow the given format. Note, because the player uses find, it will search the files for you. (A true playlist, so you don't have to add the file-list paths.. that would be bullshit.) It will also add multiple hits into the playlist! (Some push action for ya.)

    # This is a tracklist for my # Deftones # Mix Playlist #1 # July 2013 # # 1. Diamond Eyes # 2. My Own Summer # 3. CMND_CTRL # 4. 7 Words # 5. Hexagram # 6. Minerva # 7. Knife Party # 8. Rocket Skates # 9. Royal # 10. Passenger (feat. Maynard James Keenan) # 11. Change (In The House Of Flies) # 12. Sextape
Ultraviolet: A script for cross-checking VIO server configurations in a IBM Power(n) LPAR environment
No replies — Read more | Post response
by bpoag
on Jul 31, 2013 at 14:17

    As anyone who's ventured into the VIO jungle can tell you, it's a pain in the ass.. Mainly due to the fact that despite functioning as a cluster*, VIO administration requires ongoing human-driven manual configuration on each node. This will eventually produce gradually divergent configurations on the nodes over time, which can come back to haunt you.

    Recently, we had occasion where the failure of one VIO node caused an LPAR to go haywire. We eventually tracked the problem down to a LUN mismatch. To avoid this happening in the future, I put together a quick script to compare the LUN mappings on two VIO servers, to ensure that what was present on one was indeed present on the other, and to ensure that everything looked safe, sane, and failover-ready.

    One of the problems with IBM's VIO model is that the administrator is generally jailed in a shell that doesn't permit ready access to the underlying AIX commands that are only granted after issuing oem_setup_env. This script includes a handy routine for getting around that problem, remotely.

    (* = I use the term "cluster" loosely..Rather than strictly syncronized active/passive peer nodes, for some reason IBM decided it would be better to have the VIO servers in a relationship that more resembles two siblings who rarely if ever stay in touch but cooperate with eachother if a family member dies.)


    Here's some example output:

    (12:08:06)(foobarbaz)(~) bowie : ./ultraviolet.pl bogonvio1 bogonvio2 Ultraviolet: Starting up.. Ultraviolet: Collecting configuration info from bogonvio1 and bogonvio +2.......... Ultraviolet: Sorting things out..... Ultraviolet: Test Result Notes Ultraviolet: --------------------------------------------------------- +---------------------------------------- Ultraviolet: PV Count PASS Overall PV counts are equiv +alent between VIO servers. Ultraviolet: PV Match A to B PASS All PVIDs present on bogonv +io1 are present on bogonvio2. Ultraviolet: PV Match B to A PASS All PVIDs present on bogonv +io2 are present on bogonvio1. Ultraviolet: Active Vhost Count PASS The same number of vhosts a +re active on both VIO servers. Ultraviolet: Involved LPAR Count PASS The same number of of LPARS + are involved on both VIO servers. Ultraviolet: LPARs A to B PASS All LPARs mentioned on bogo +nvio1 are present on bogonvio2. Ultraviolet: LPARs B to A PASS All LPARs mentioned on bogo +nvio2 are present on bogonvio1. Ultraviolet: LUN ID Match FAIL LUN IDs don't match between + bogonvio1 and bogonvio2. Ultraviolet: Backing Device Match FAIL The hdisk enumeration is di +fferent between bogonvio1 and bogonvio2. Ultraviolet: Ultraviolet: Problems found: Ultraviolet: Ultraviolet: Backing device mismatch detected. (foobarbaz_foovg is hdi +sk59 on bogonvio1, but on bogonvio2 it's hdisk47) Ultraviolet: Backing device mismatch detected. (foobarbaz_bazvg is hdi +sk61 on bogonvio1, but on bogonvio2 it's hdisk49) Ultraviolet: Backing device mismatch detected. (foobarbaz_baz01 is hdi +sk51 on bogonvio1, but on bogonvio2 it's hdisk39) Ultraviolet: Backing device mismatch detected. (foobarbaz_baz02 is hdi +sk52 on bogonvio1, but on bogonvio2 it's hdisk40) Ultraviolet: Backing device mismatch detected. (foobarbaz_baz03 is hdi +sk53 on bogonvio1, but on bogonvio2 it's hdisk41) Ultraviolet: Backing device mismatch detected. (foobarbaz_baz04 is hdi +sk54 on bogonvio1, but on bogonvio2 it's hdisk42) Ultraviolet: Backing device mismatch detected. (foobarbaz_baz05 is hdi +sk55 on bogonvio1, but on bogonvio2 it's hdisk43) Ultraviolet: Backing device mismatch detected. (foobarbaz_baz06 is hdi +sk56 on bogonvio1, but on bogonvio2 it's hdisk44) Ultraviolet: Backing device mismatch detected. (foobarbaz_baz07 is hdi +sk57 on bogonvio1, but on bogonvio2 it's hdisk45) Ultraviolet: Backing device mismatch detected. (foobarbaz_foovg is hdi +sk62 on bogonvio1, but on bogonvio2 it's hdisk50) Ultraviolet: Backing device mismatch detected. (foobarbaz_foovg is hdi +sk58 on bogonvio1, but on bogonvio2 it's hdisk46) Ultraviolet: Backing device mismatch detected. (bazfoobar_foovg is hdi +sk63 on bogonvio1, but on bogonvio2 it's hdisk52) Ultraviolet: Backing device mismatch detected. (bazfoobar_baz01 is hdi +sk16 on bogonvio1, but on bogonvio2 it's hdisk18) Ultraviolet: Backing device mismatch detected. (bazfoobar_baz02 is hdi +sk17 on bogonvio1, but on bogonvio2 it's hdisk19) Ultraviolet: Backing device mismatch detected. (bazfoobar_baz04 is hdi +sk31 on bogonvio1, but on bogonvio2 it's hdisk32) Ultraviolet: Backing device mismatch detected. (bazfoobar_baz05 is hdi +sk32 on bogonvio1, but on bogonvio2 it's hdisk35) Ultraviolet: Backing device mismatch detected. (bazfoobar_baz06 is hdi +sk50 on bogonvio1, but on bogonvio2 it's hdisk38) Ultraviolet: Backing device mismatch detected. (bazfoobar_foovg is hdi +sk64 on bogonvio1, but on bogonvio2 it's hdisk53) Ultraviolet: Backing device mismatch detected. (bazfoobar_foovg is hdi +sk65 on bogonvio1, but on bogonvio2 it's hdisk54) Ultraviolet: Backing device mismatch detected. (bazbazfoo_bazfoo is hd +isk36 on bogonvio1, but on bogonvio2 it's hdisk37) Ultraviolet: Backing device mismatch detected. (bazbazfoo_bazfoo1 is h +disk37 on bogonvio1, but on bogonvio2 it's hdisk51) Ultraviolet: Backing device mismatch detected. (bazbazfoo_bazfoo2 is h +disk116 on bogonvio1, but on bogonvio2 it's hdisk105) Ultraviolet: Backing device mismatch detected. (bazbazfoo_bazfoo3 is h +disk117 on bogonvio1, but on bogonvio2 it's hdisk106) Ultraviolet: Backing device mismatch detected. (bazbazfoo_bazfoo4 is h +disk118 on bogonvio1, but on bogonvio2 it's hdisk107) Ultraviolet: Backing device mismatch detected. (bazbazfoo_foo01 is hdi +sk119 on bogonvio1, but on bogonvio2 it's hdisk108) Ultraviolet: Backing device mismatch detected. (bazbazfoo_foo is hdisk +35 on bogonvio1, but on bogonvio2 it's hdisk36) Ultraviolet: Backing device mismatch detected. (bazbarfoo92_bar01 is h +disk14 on bogonvio1, but on bogonvio2 it's hdisk13) Ultraviolet: Backing device mismatch detected. (bazbarfoo92_bar02 is h +disk18 on bogonvio1, but on bogonvio2 it's hdisk14) Ultraviolet: Backing device mismatch detected. (bazbarfoo92_bar03 is h +disk19 on bogonvio1, but on bogonvio2 it's hdisk15) Ultraviolet: Backing device mismatch detected. (bazbarfoo92_bar04 is h +disk20 on bogonvio1, but on bogonvio2 it's hdisk16) Ultraviolet: Backing device mismatch detected. (bazbarfoo92_bar01 is h +disk1 on bogonvio1, but on bogonvio2 it's hdisk0) Ultraviolet: Backing device mismatch detected. (bazbarfoo92_bar02 is h +disk11 on bogonvio1, but on bogonvio2 it's hdisk1) Ultraviolet: Backing device mismatch detected. (bazbarfoo92_bar03 is h +disk12 on bogonvio1, but on bogonvio2 it's hdisk3) Ultraviolet: Backing device mismatch detected. (bazbarfoo92_bar04 is h +disk13 on bogonvio1, but on bogonvio2 it's hdisk12) Ultraviolet: Backing device mismatch detected. (bazbarfoo_foo01 is hdi +sk130 on bogonvio1, but on bogonvio2 it's hdisk119) Ultraviolet: Backing device mismatch detected. (bazbarfoo_barvg is hdi +sk129 on bogonvio1, but on bogonvio2 it's hdisk118) Ultraviolet: Backing device mismatch detected. (bazbarfoo_foovg is hdi +sk15 on bogonvio1, but on bogonvio2 it's hdisk17) Ultraviolet: Backing device mismatch detected. (bazbarfoo_foo01 is hdi +sk136 on bogonvio1, but on bogonvio2 it's hdisk125) Ultraviolet: Backing device mismatch detected. (bazbarfoo_foo02 is hdi +sk137 on bogonvio1, but on bogonvio2 it's hdisk126) Ultraviolet: Backing device mismatch detected. (bazbarfoo_foo03 is hdi +sk138 on bogonvio1, but on bogonvio2 it's hdisk127) Ultraviolet: Backing device mismatch detected. (bazbarfoo_baz01 is hdi +sk139 on bogonvio1, but on bogonvio2 it's hdisk128) Ultraviolet: Backing device mismatch detected. (bazbarfoo_baz02 is hdi +sk140 on bogonvio1, but on bogonvio2 it's hdisk129) Ultraviolet: Backing device mismatch detected. (bazbarfoo_baz03 is hdi +sk141 on bogonvio1, but on bogonvio2 it's hdisk130) Ultraviolet: Backing device mismatch detected. (foobarfoo_bar01 is hdi +sk3 on bogonvio1, but on bogonvio2 it's hdisk4) Ultraviolet: Backing device mismatch detected. (foobarfoo_bar02 is hdi +sk4 on bogonvio1, but on bogonvio2 it's hdisk5) Ultraviolet: Backing device mismatch detected. (foobarfoo_bar03 is hdi +sk5 on bogonvio1, but on bogonvio2 it's hdisk6) Ultraviolet: Backing device mismatch detected. (foobarfoo_bar04 is hdi +sk6 on bogonvio1, but on bogonvio2 it's hdisk7) Ultraviolet: Backing device mismatch detected. (barbazfoo_barvg is hdi +sk115 on bogonvio1, but on bogonvio2 it's hdisk104) Ultraviolet: Backing device mismatch detected. (barbazfoo_bazfoo is hd +isk109 on bogonvio1, but on bogonvio2 it's hdisk83) Ultraviolet: Backing device mismatch detected. (barbazfoo_bazfoo1 is h +disk110 on bogonvio1, but on bogonvio2 it's hdisk84) Ultraviolet: Backing device mismatch detected. (barbazfoo_bazfoo2 is h +disk111 on bogonvio1, but on bogonvio2 it's hdisk85) Ultraviolet: Backing device mismatch detected. (barbazfoo_bazfoo3 is h +disk112 on bogonvio1, but on bogonvio2 it's hdisk88) Ultraviolet: Backing device mismatch detected. (barbazfoo_bazfoo4 is h +disk113 on bogonvio1, but on bogonvio2 it's hdisk102) Ultraviolet: Backing device mismatch detected. (barbazfoo_foo01 is hdi +sk114 on bogonvio1, but on bogonvio2 it's hdisk103) Ultraviolet: Backing device mismatch detected. (barbazfoo_foovg is hdi +sk60 on bogonvio1, but on bogonvio2 it's hdisk80) Ultraviolet: Backing device mismatch detected. (barbarfoo_baz01 is hdi +sk122 on bogonvio1, but on bogonvio2 it's hdisk111) Ultraviolet: Backing device mismatch detected. (barbarfoo_baz02 is hdi +sk123 on bogonvio1, but on bogonvio2 it's hdisk112) Ultraviolet: Backing device mismatch detected. (barbarfoo_baz03 is hdi +sk124 on bogonvio1, but on bogonvio2 it's hdisk113) Ultraviolet: Backing device mismatch detected. (barbarfoo_foovg is hdi +sk125 on bogonvio1, but on bogonvio2 it's hdisk114) Ultraviolet: Backing device mismatch detected. (barbarfoo_bar01 is hdi +sk7 on bogonvio1, but on bogonvio2 it's hdisk8) Ultraviolet: Backing device mismatch detected. (barbarfoo_bar02 is hdi +sk8 on bogonvio1, but on bogonvio2 it's hdisk9) Ultraviolet: Backing device mismatch detected. (barbarfoo_bar03 is hdi +sk9 on bogonvio1, but on bogonvio2 it's hdisk10) Ultraviolet: Backing device mismatch detected. (barbarfoo_bar04 is hdi +sk10 on bogonvio1, but on bogonvio2 it's hdisk11) Ultraviolet: LUN Name-to-ID mismatch detected. (foobarfoo_bar01 has a +LUN ID of 0x8400000000000000 on bogonvio1, but on bogonvio2 it's 0x85 +00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (foobarfoo_bar02 has a +LUN ID of 0x8500000000000000 on bogonvio1, but on bogonvio2 it's 0x88 +00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (foobarfoo_bar03 has a +LUN ID of 0x8800000000000000 on bogonvio1, but on bogonvio2 it's 0x89 +00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (foobarfoo_bar04 has a +LUN ID of 0x8900000000000000 on bogonvio1, but on bogonvio2 it's 0x8a +00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbazfoo_barvg has a +LUN ID of 0x9100000000000000 on bogonvio1, but on bogonvio2 it's 0x8d +00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbazfoo_bazfoo has a + LUN ID of 0x8b00000000000000 on bogonvio1, but on bogonvio2 it's 0x8 +f00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbazfoo_bazfoo1 has +a LUN ID of 0x8c00000000000000 on bogonvio1, but on bogonvio2 it's 0x +9000000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbazfoo_bazfoo2 has +a LUN ID of 0x8d00000000000000 on bogonvio1, but on bogonvio2 it's 0x +9100000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbazfoo_bazfoo3 has +a LUN ID of 0x8e00000000000000 on bogonvio1, but on bogonvio2 it's 0x +9200000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbazfoo_bazfoo4 has +a LUN ID of 0x8f00000000000000 on bogonvio1, but on bogonvio2 it's 0x +8b00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbazfoo_foo01 has a +LUN ID of 0x9000000000000000 on bogonvio1, but on bogonvio2 it's 0x8c +00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbazfoo_foovg has a +LUN ID of 0x9200000000000000 on bogonvio1, but on bogonvio2 it's 0x8e +00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbarfoo_bar01 has a +LUN ID of 0x8a00000000000000 on bogonvio1, but on bogonvio2 it's 0x8b +00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbarfoo_bar02 has a +LUN ID of 0x8b00000000000000 on bogonvio1, but on bogonvio2 it's 0x8c +00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbarfoo_bar03 has a +LUN ID of 0x8c00000000000000 on bogonvio1, but on bogonvio2 it's 0x83 +00000000000000) Ultraviolet: LUN Name-to-ID mismatch detected. (barbarfoo_bar04 has a +LUN ID of 0x8300000000000000 on bogonvio1, but on bogonvio2 it's 0x84 +00000000000000)
    Here's the code:

Automate Word from Perl
No replies — Read more | Post response
by jmk2012
on Jul 12, 2013 at 17:02

    In trying to find examples on how to automate Word document creation from Perl, I found this website and the accompanying code posted by Rene Nyffenegger. It is elegant in style and simplicity. Thank you Rene.

    http://www.adp-gmbh.ch/perl/word.html

    use warnings; use strict; use Win32::OLE; my $word = CreateObject Win32::OLE 'Word.Application' or die $!; $word->{'Visible'} = 1; my $document = $word->Documents->Add; my $selection = $word->Selection; $selection -> TypeText("Hello World"); $selection -> TypeParagraph; $selection -> TypeText("How do you feel today"); $selection -> TypeParagraph; $selection -> TypeText("Some header"); $selection -> {'Style'} = "Heading 1"; $selection -> TypeParagraph; my $heading_1 = $document->Styles("Heading 1"); my $heading_1_font = $heading_1 -> Font; $heading_1_font -> {Name} = "Bookmann"; $heading_1_font -> {Size} = 20; $heading_1_font -> {Bold} = 1;

    ============ Here's an example that does a little more: ==============

    use warnings; use strict; use Win32::OLE; use Win32::OLE::Const 'Microsoft.Word'; # wd constants use Win32::OLE::Const 'Microsoft Office'; # mso constants my $cur_style = 'a'; my $cur_bookmark = 'a'; my $word = CreateObject Win32::OLE 'Word.Application' or die $!; $word->{'Visible'} = 1; my $document = $word->Documents->Add; # selection is the insertion point. my $selection = $word->Selection; my $st_bold_10_arial = create_style($document, "Arial", 10, 1, 0); my $st_italic_10_arial = create_style($document, "Arial", 10, 0, 1); my $st_italic_20_arial = create_style($document, "Times new Roman", 20 +, 0, 1); set_style($document, $st_bold_10_arial); text ($document, "This text is bold, 10 points and arial"); enter ($document); set_style($document, $st_italic_10_arial); text ($document, "This text is italic, 10 points and arial"); enter ($document); set_style($document, $st_italic_20_arial); text ($document, "This text is italic, 20 points and Times"); # insert something into the header switch_view($document, wdSeekCurrentPageHeader); my $st_header = create_style($document, "Verdana", 8, 0, 0); set_style($document, $st_header); text ($document, "this is the document's header, it will be repeat +ed on all pages"); # insert something into the footer switch_view($document, wdSeekCurrentPageFooter); my $st_footer = create_style($document, "Verdana", 8, 0, 0); set_style($document, $st_footer); text ($document, "this is the document's footer, it will be repeat +ed on all pages"); # Inserting current page, total page text ($document, " Page "); $selection->Fields->Add ($selection->{Range}, wdFieldPage ); text ($document, " of "); $selection->Fields->Add ($selection->{Range}, wdFieldNumPages); # go back to body of document switch_view($document, wdSeekMainDocument); my $picture = insert_picture($document, 'c:\some\path\to\the\file.eps' +, 100, 100, 100, 30); my $st_12_arial = create_style($document, "Arial", 12, 0, 0); ############################# Demonstrating Bookmarks ##### enter ($document); # set_style($document, $st_12_arial); # text ($document, "Not bold"); # bold ($document, 1); # text ($document, " but this IS bold "); # bold ($document, 0); # text ($document, "this is not bold anymore"); # enter ($document); # # my $first_bookmark = insert_bookmark($document); # text ($document, "here's a bookmark"); # enter ($document); # text ($document, "Writing some lines"); # enter ($document); # text ($document, "Before going to the bookmark"); # enter ($document); # # my $second_bookmark = insert_bookmark($document); # goto_bookmark($document, $first_bookmark); # text ($document, "Went back to first bookmark"); # goto_bookmark($document, $second_bookmark); # text ($document, "Went back to second bookmark"); # ############################################################# ############### indenting ############## my $st_indent = create_style($document, "Arial", 10, 0, 0); style_indents($document, $st_indent, 100, 200); enter ($document); set_style ($document, $st_indent); text ($document, join " ", 1 .. 100); enter ($document); text ($document, join " ", 'a' .. 'cz'); items ($document, "Fruits", $st_indent, qw(Apple Pear Peach Che +rry Nectarine Orange)); items ($document, "Shapes", $st_indent, qw(Triangle Rhombus Tra +pezoid Pentagon Circle)); ## inserting a box my $st_box = create_style($document, "Arial", 8, 0, 1); style_indents($document, $st_box, 0, 0); my $box = insert_box($document, 350, 550, 140, 40); set_style($document, $st_box); text ($document, "hello out of the box"); save_doc_as($document, 'c:\generated.doc'); ## uncomment the following two if word should shut down # close_doc($document); # $word->Quit; sub text { my $document = shift; my $text = shift; $document->ActiveWindow->Selection -> TypeText($text); } # aka new line, newline or NL sub enter { my $document = shift; $document->ActiveWindow->Selection -> TypeParagraph; } sub set_style { my $document = shift; my $style_arg = shift; $document->ActiveWindow->Selection -> {Style} = $style_arg -> {name} +; } sub create_style { my $document = shift; my $fontname = shift; my $font_size = shift; my $bold = shift; my $italic = shift; my $style = $document->Styles->Add($cur_style); my $style_font = $style->{Font}; $style_font -> {Name } = $fontname; $style_font -> {Size } = $font_size; $style_font -> {Bold } = $bold; $style_font -> {Italic} = $italic; my %style; $style{name} = $cur_style++; return \%style; } # use switch_view to change to header, footer, main document and so on +... # possible constants for view are: wdSeekCurrentPageFooter # # o wdSeekCurrentPageHeader # o wdSeekEndnotes # o wdSeekEvenPagesFooter # o wdSeekEvenPagesHeader # o wdSeekFirstPageFooter # o wdSeekFirstPageHeader # o wdSeekFootnotes # o wdSeekMainDocument # o wdSeekPrimaryFooter # o wdSeekPrimaryHeader # sub switch_view { my $document = shift; my $view = shift; $document -> ActiveWindow -> ActivePane -> View -> {SeekView} = $vie +w; } sub insert_picture { my $document = shift; my $file = shift; my $left = shift; my $top = shift; my $width = shift; my $height = shift; my $picture = $document-> Shapes -> AddPicture ( $file, msoFalse, # link to file msoTrue, # save with document $left, $top, $width, $height, $document->ActiveWindow->Selection->{Range} ); return $picture; } sub bold { my $document = shift; my $bold = shift; $document->ActiveWindow->Selection->{Font}->{Bold} = $bold ? msoTrue + : msoFalse; } sub goto_bookmark { my $document = shift; my $bookmark = shift; $document->ActiveWindow->Selection -> GoTo(wdGoToBookmark, 0, 0, $bo +okmark->{Name}); } sub insert_bookmark { my $document = shift; my $bookmark = $document -> Bookmarks -> Add ($cur_bookmark++, $docu +ment->ActiveWindow->Selection->Range); return $bookmark; } sub style_indents { my $document = shift; my $style_arg = shift; my $first_line_indent = shift; my $other_line_indent = shift; my $style = $document->Styles($style_arg->{name}); $style->ParagraphFormat->{LeftIndent } = $other_line_indent; $style->ParagraphFormat->{FirstLineIndent} = -$other_line_indent + $ +first_line_indent; } sub items { my $document = shift; my $title = shift; my $style = shift; my @array = @_; enter($document); set_style($document, $style); bold($document, 1); text($document, $title); bold($document, 0); text($document, "\x09"); foreach my $a (@array) { text($document, $a); text($document, "\x0b"); } } sub insert_box { my $document = shift; my $left = shift; my $top = shift; my $width = shift; my $height = shift; my $shape = $document->Shapes->AddTextbox(msoTextOrientationHorizont +al, $left, $top, $width, $height); $shape -> Select; my $selection = $word->Selection; $selection -> ShapeRange -> Line -> {DashStyle} = msoLineRoundDot; return $shape } sub close_doc { my $document = shift; $document -> Close; } sub save_doc_as { my $document = shift; my $filename = shift; $document->SaveAs($filename); } sub style_keep_with_next { my $document = shift; my $style_arg = shift; my $style = $document->Styles($style_arg->{name}); $style->{ParagraphFormat}->{KeepWithNext} = msoTrue; } sub style_keep_together { my $document = shift; my $style_arg = shift; my $style = $document->Styles($style_arg->{name}); $style->{ParagraphFormat}->{KeepTogether} = msoTrue; } sub style_border { my $document = shift; my $style_arg = shift; my $border = shift; my $border_style = shift; my $border_width = shift; my $border_color = shift; my $style = $document->Styles($style_arg->{name}); $style->Borders($border) -> {LineStyle} = $border_style; $style->Borders($border) -> {LineWidth} = $border_width; $style->Borders($border) -> {Color } = $border_color; } sub style_tab_at_position { my $document = shift; my $style_arg = shift; my $position = shift; my $left_or_right= shift; my $style = $document->Styles($style_arg->{name}); $style->ParagraphFormat->{TabStops}->Add($word->InchesToPoints($posi +tion), $left_or_right); } sub style_space_before { my $document = shift; my $style_arg = shift; my $space = shift; my $style = $document->Styles($style_arg->{name}); $style->ParagraphFormat->{SpaceBefore} = $space; } sub style_space_after { my $document = shift; my $style_arg = shift; my $space = shift; my $style = $document->Styles($style_arg->{name}); $style->ParagraphFormat->{SpaceAfter} = $space; } sub style_alignment { my $document = shift; my $style_arg = shift; my $alignment = shift; my $style = $document->Styles($style_arg->{name}); $style->ParagraphFormat->{Alignment} = $alignment; } sub goto_end_of_document { my $document = shift; $document->ActiveWindow->Selection->{Range} -> EndKey(wdStory); #my $selection = $word->Selection; #$selection -> EndKey (wdStory); } sub insert_page_break { my $document = shift; #my $selection = $word->Selection; #$selection -> InsertBreak(wdPageBreak); $document->ActiveWindow->Selection->{Range} -> InsertBreak(wdPageBre +ak); } sub landscape { my $document = shift; $document->PageSetup->{Orientation} = wdOrientLandscape; }

    Again, thanks to Rene Nyffenegger for his post of this code

wxPerl Integration with GD::Graph Example
No replies — Read more | Post response
by jmlynesjr
on Jun 29, 2013 at 15:43

    For your graphing enjoyment...an L or C Impedance Graph with selectable frequency sweep and scaling.

    Original version used the Gnome viewer to display the graph. This "final" version uses a PaintDC and is thus platform independant. Many thanks to Mark Dootson for the PaintDC code.

    Cross-Posted to wxperl-users.org

    James

    There's never enough time to do it right, but always enough time to do it over...

hexdump2bin: convert hexdump -C like output back to binary
No replies — Read more | Post response
by dmitri
on Jun 18, 2013 at 22:02
    #!/usr/bin/perl # Convert hexdump -C like output back to binary. Supports * lines, wh +ich # xxd -r does not (this is the reason for this script). Assumes good +input. use strict; use warnings; my ($off, $line, $asterisk); while (<>) { if (/^([[:xdigit:]]{2,}0)\s+((?:[[:xdigit:]]{2}\s+){1,16})/) { if (defined($asterisk)) { my $nlines = (hex($1) - hex($off)) / 16 - 1; print map { chr hex } split /\s+/, $line x $nlines; undef $asterisk; } print map { chr hex } split /\s+/, $2; $off = $1, $line = $2; } elsif (/^\*/) { $asterisk = 1; } else { last; } }

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 lurking in the Monastery: (6)
    As of 2014-04-17 04:25 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      April first is:







      Results (439 votes), past polls