Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?

Cool Uses for Perl

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

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

Substitution cipher or keyboard layout demo
2 direct replies — 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


    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

    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 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 --------------------------------------------------------------
Sidef - The experimental scripting language written in Perl
No replies — Read more | Post response
by trizen
on Apr 17, 2014 at 09:28

    I remember that, a few years ago, someone asked a question about Writing a Programming Language in Perl. I was a little bit skeptical at first, but very interested in this subject too. Few years passed by, until me and a friend of mine decided to create a toy-language from scratch without using anything else, but Perl. We wanted it as simple as possible and powerful as much as it can be.

    Object-oriented paradigm must be the answer, right? We thought so. And it is, partially. The language we designed is called Sidef. It strongly follows the OO style; each piece of data is stored inside objects with own methods and operators defined to work on that type of data. (actually, in Sidef, an operator and a method are the same thing)

    Simplicity? What do we mean by something simple? How simple can a programming language be defined? This is the main question that I wanted to answer. A year after the start of the project, I think we found a reasonable answer: objects and methods. This is, I think, the simplest way a programming language can be defined. But, what about conditional expressions? They can't be created by objects and methods only, right? Wrong! They can:

    if (false) { } elsif (true) { } else { }
    is equivalent with:
    var condObj = if(false); # 'if' object condObj do { } elsif(true) do { } else { }
    What? Yes, the above code is valid code. if(expr) returns an object which accepts methods like 'do', 'elsif' and 'else'.
    This proves how flexible an OO language can be. The basic definition of Sidef is this: obj.method(obj), with minor exceptions.

    Objects are:
    • strings
    • files
    • numbers
    • arrays
    • everything else
    while methods are functions defined for that kind of object which returns other objects.

    In Sidef, the numbers have a very special purpose. We see the language as a toy-language and recommend to be seen only this way, but still it can be used in simple home-made projects, especially in those involving number computation. Numbers, by default, are represented by Math::BigFloat objects, giving them a better precision at the cost of being somewhat slower than Perl's standard representation for numbers (-Nfast).

    Perl related features:
    • any Sidef script can be compiled to a stand-alone Perl program (-c)
    • can load and use Perl modules (both OO and functional)
    • can evaluate arbitrary Perl code (Sys.eval(""))
    • supports memoization via Memoize (-M) (not enabled by default)
    • no CPAN module is required

    The project is available at:
    The documentation page:
    The RosettaCode page:

    The very basic concept of the language can be found at:

check modules used by a script and their version
2 direct replies — Read more / Contribute
by Discipulus
on Apr 03, 2014 at 06:26
    another CUFP or better WICDWMBP (what i can do with my baby Perl)..
    Reading this post i'm started wondering if there was a way to wrap an existing script and grab modules it uses without exucuting it.
    Obviously the answer or part of it was in the monastery: here
    I very liked the
    perl -d:Modlist=options perl -MDevel::Modlist=options # equivalent
    part but, unfortunately it executes the
    Also liked the tachyon-II hack, but you have to edit the and i'm too lazy.
    No hope to use $^C = 1 as pointed wisely by shmem

    The UNITCHECK do the trick! Never known it seems quite usefull for this task: read about it

    #!perl #use strict; #commented to not pollute %INC #use warnings;#commented to not pollute %INC my $file = $ARGV[0]; my $content = do { open my $fh, '<', $file or die $!; local $/; <$fh> +}; my $begin =<<'THEEND'; UNITCHECK { no strict; # access $VERSION by symbolic reference no warnings qw (uninitialized); print map { s!/!::!g; s!.pm$!!; sprintf "%-20s %s\n", $_, ${"${_}::VERSION"} } sort keys %INC; exit; }; THEEND eval $begin.$content; print $@ if $@;
    Enjoy the results!

    UPDATE 9 april 2014: BE CAREFULL, as stated by davido and also by LanX in other post, BEGIN blocks are executed anyway. In fact BEGIN blocks come first, in order of definition, then come UNITCHECK blocks and, being that block prepended to the original code in the above program, it will be executed just after the last BEGIN block and just before any UNITCHECK defined in the original program passed in via @ARGV. In the case of perl -c -d:TraceUse all the BEGIN UNITCHECK CHECK blocks are executed.

    Here two examples to demonstrate where the -c ends his operations (a simplified version of 16 pillars of wisdom):
    perl -c -e "BEGIN{print qq(1-begin\n)}; UNITCHECK {print qq(2-unitcheck\n)}; CHECK {print qq(3-check\n)}; INIT {print qq(4-init\n)}; print qq(5-main\n); END{print qq(6-end\n)}" __OUTPUT__ 1-begin 2-unitcheck 3-check -e syntax OK # the same code without -c __OUTPUT__ 1-begin 2-unitcheck 3-check 4-init 5-main 6-end
    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.
Automatic chrome extension generator
No replies — Read more | Post response
by Discipulus
on Mar 25, 2014 at 17:27
    Well, I needed to add few extensions to the browser and i ended with this...
    It generates a working chrome extension with only a context menu that acts as 'Search with <your search engine>'.

    You'll call the script with only 2 args: a_description and a partial URL
    as in Cpan_search
    Then you point chrome to chrome://extensions/, check 'Developer Mode' and choose 'Load an unpacked extension' and browse to early created folder containing the extension.

    Here is the code:
    #!/usr/bin/perl use strict; use warnings; my $folder = $ARGV[0]; my $url = $ARGV[1]; (my $descr = $folder) =~ s/_+/ /g; my $longname = 'Perl genarated extension - '.$descr; mkdir $folder or die "Cannot create $folder: $!"; chdir $folder or die "Cannot enter $folder: $!"; # the manifest open MANIF, '>', 'manifest.json' or die "Cannot open a file to write i +n: $!"; my $manifest = '{ "manifest_version": 2, "description": "'.$descr.'", "background": { "scripts": ["background.js"]}, "name": "'.$longname.'", "permissions": [ "contextMenus", "tabs" ], "version": "1.0" }'; print MANIF $manifest; close MANIF; # the jscript open JSCRIPT, '>', 'background.js' or die "Cannot open a file to write + in: $!"; my $background ='function customfunc(info) { var searchstring = info.selectionText; chrome.tabs.create({url: "'.$url.'" + searchstring}) } chrome.contextMenus.create({title: "'.$descr.'", contexts:["selection" +], onclick: customfunc});'; print JSCRIPT $background; close JSCRIPT;
    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.
Improving reproducibility and record-keeping with Log::Reproducible (create or re-run archive of script parameters, git snapshot, etc.)
2 direct replies — Read more / Contribute
by frozenwithjoy
on Mar 25, 2014 at 02:08

    I wrote a Perl module, Log::Reproducible, to help improve reproducibility (and record-keeping) of analyses. The code, README, and (some) tests are hosted on GitHub. I'm posting the README below. It contains relevant code snippets and describes how to use Log::Reproducible. If interested, please take a look the code on GitHub. I'm aiming to submit to CPAN and would really appreciate any feedback.

    EDIT: Added code for module, too (at very bottom)

    EDIT #2: Thanks to a suggestion by DrHyde in a GitHub issue, I've added some Perl-related info to the archives: version, path to the perl binary that was used, and @INC. It has already been pushed to the develop branch. Next, I'll update the module so that current vs archived Perl info is compared when reproducing an archive. In the event that the info doesn't match, the script will bail or the user will be prompted whether or not to continue.

    Note: I've tested this module alongside other modules that use and/or manipulate @ARGV and have not found any conflicts as long as Log::Reproducible is imported before the other modules.

    TAG LINE: Increase your reproducibility with the Perl module Log::Reproducible. Set it and forget it... until you need it!

    MOTIVATION: In science (and probably any other analytical field), reproducibility is critical. If an analysis cannot be faithfully reproduced, it was arguably a waste of time. Log::Reproducible provides effortless record keeping of the conditions under which scripts are run and allows easily replication of those conditions.

My own dynamic DNS setup
1 direct reply — Read more / Contribute
by Corion
on Mar 24, 2014 at 04:05

    I'm using, but recently they got more obnoxious with their (free!) service, and being a cheapskate who doesn't want to be annoyed, I set up my own dynamic DNS update with my vhost at Hosteurope. I have set up as the DNS server for the zone with the Hosteurope DNS and run my own DNS server on my vhost to serve entries for * The key setup is done according to the many dynamic DNS articles.

    The below program reads the external IP address from my UPnP enabled gateway, a FritzBox. It then sends the signed DNS update packet to my DNS server.

    The setup is not particularly secure, as the key can be used to update any dynamic IP address in the zone. But for my purpose of having one name map to a dynamic IP address, that's just enough.

Yet Another Perl-to-Lambda-Calculus Translator
1 direct reply — Read more / Contribute
by withering
on Mar 18, 2014 at 23:19

    There is an old post about Perl (maybe perl?) and (untyped) lambda calculus . However, even from the perspective of a small compiler, we may reach almost the same simplicity.

    The code below is written in yapp (Parse::Yapp) grammar and should be compiled with yapp utilities:

Translating simplex noise code from java to perl
2 direct replies — Read more / Contribute
by grondilu
on Mar 03, 2014 at 14:57

    Hi monks,

    I've been growing an interest for computer graphics lately, and most especially for proceduraly generated landscapes (the kind of stuff we can see in open-world or sandbox games). So while educating myself on this subject I learnt a few things about noise, and I learnt about the so-called Perlin noise, which was invented in the eighties or something. In 2002, Perlin improved his algorithm by using a better tesselation of space. It's called the Simplex noise and it's discussed and explained by Stefan Gustavson in this document, while providing a java implementation in public domain.

    Well, I don't like java so I wanted to translate it into Perl. I've done it for the 2D dimension, and I thought it was worth sharing with you monks. I'll certainly translate the rest (3D and 4D) later. I will almost certainly write a Perl 6 version as well.

    I also added a few lines to create a noise image in PGM format. Here is the result:

    And here is the code (the original java code is in the __END__)

Will I break CPAN?
2 direct replies — Read more / Contribute
by Tux
on Mar 03, 2014 at 09:46

    Once one of your modules on CPAN is used/required by another module on CPAN not under your own control, it might be a good idea to test all those modules with your new code to verify you didn't break anything.

    The first thing you want to check is the fact that your module actually is used by something else. We are in luck here, as that is already done for us. For this example, I'll continue with a short and simple module (Data::Peek) as the logs are much shorter, but the process is exactly the same as for a module that is used widely, as DBI or Text::CSV_XS, for which I wrote this to begin with.

    Before you want to check other modules, of course you check your own suite:

    $ perl Makefile.PL $ make test : All tests successful. : Result: PASS $ make distcheck

    So the module passes, but does it still pass in the modules that require it? To test that, we first need to see what that lists consists of. CPANTS has that list readily available for each module on CPAN. We can use the internals of CPAN to fetch and test that list.

    That fetches the list of modules that require Data::Peek, check if any of those is recognized by CPAN, for each makes a call to CPAN's test function/method, catches all the output with Capture::Tiny (and ignores all output for now) and use the return code available in $? to decide FAIL or success:

    $ prove -vwb sandbox/ sandbox/ .. Reading '/home/merijn/.cpan/Metadata' Database was generated on Mon, 03 Mar 2014 14:17:02 GMT CPAN: YAML loaded ok (v0.90) Reading 3 yaml files from /home/merijn/.cpan/build/ ..........................DONE Restored the state of 1 (in 0.0431 secs) ok 1 - App::tkiv ok 2 - Geo::KML ok 3 - Spreadsheet::Read 1..3 ok All tests successful. Files=1, Tests=3, 13 wallclock secs ( 0.02 usr 0.00 sys + 10.29 cusr + 0.60 csys = 10.91 CPU) Result: PASS $

    Running this for Text::CSV_XS resulted in 4 RT tickets with patches on other modules that failed depending on Text::CSV_XS where they did either something wrong or were not yet up to date with new(er) code.

    If I find myself not forgetting to run this before I release a new module, I think I will prevent a lot of complaints later :)

    Enjoy, Have FUN! H.Merijn
Mojolicious RSS Aggregator
No replies — Read more | Post response
by onelander
on Mar 02, 2014 at 14:43

    I created a single user Mojolicious based RSS aggregator. It uses PostgreSQL for its database. I had attempted to use SQLite when I first started but I ran into some problems with reliability and I have not had much of a need to go back.

    It is pretty minimal for Mojolicious use as well a JavaScript to get the work done.

    I have been using it everyday for several months and it has been quite stable. At the moment it is a single file script.

    I wrote it to be usable from a desktop web browser but also from a mobile browser as well. I only have access to an Android Galaxy S3 so I cannot say how well it will work on iPhones or other devices.

    Here are some features

    • Mobile friendly
    • Can favorite items
    • Can delete news items that are older than X amount of days you choose
    • Fairly light weight when it comes to the web client with respect to JavaScript
    • You mark all current news items as read
    • You will only see items that have current news
    • If you are on a long list of news items you can jump back to the top of the page quite easily

    You can find it here on GitHub

parallelism v.python
3 direct replies — Read more / Contribute
by perl-diddler
on Feb 28, 2014 at 13:53
    Someone was asking on a list why their program wasn't getting expected results (had to due with "unit of measurement" inconsistencies). But to test they'd written the program in python -- for 9 threads, they got < 2 cores utilization. I was curious how perl would do. So I tried to follow the python structure as much as possible.

    First the programs, python:

    #!/usr/bin/python import operator import hashlib from threading import Thread def ticks_all(): with open('/proc/stat') as f: cpu = f.readline().split() return (int(cpu[1]), int(cpu[3])) def ticks_process(): with open('/proc/self/stat') as f: cpu = f.readline().split() return (int(cpu[13]), int(cpu[14])) def do_work(): d = hashlib.md5() d.update('nobody inspects') for i in xrange(0, 10000000): d.update(' the spammish repetition') before_all_user, before_all_sys = ticks_all() before_process_user, before_process_sys = ticks_process() threads = [] for i in xrange(0, 8): t = Thread(target=do_work) threads.append(t) t.start() for t in threads: t.join() after_process_user, after_process_sys = ticks_process() after_all_user, after_all_sys = ticks_all() print 'delta process: user:', after_process_user - before_process_user +, 'sys:', after_process_sys - before_process_sys print 'delta all: user:', after_all_user - before_all_user, 'sys:', af +ter_all_sys - before_all_sys
    Then my attempt at a perl approximation (I don't really know python, so if anyone sees anywhere I booboo'd, feel free to politely point it out ;-).
    #!/usr/bin/perl use 5.16.0; use threads; sub open_for_read($) { open(my $handle, "<$_[0]") or die "opening $_[0]: $!"; $handle } sub ticks_all { my $f = open_for_read("/proc/stat"); return (split ' ', <$f>)[1,3] } sub ticks_process() { my $f = open_for_read("/proc/self/stat"); return (split ' ', <$f>)[13,14] } sub dowork () { use Digest::MD5; my $d = Digest::MD5->new; $d->add('nobody inspects'); $d->add(' the spammish repetition') for (0 .. 10_000_000)} my ($before_all_user, $before_all_sys) = ticks_all(); my ($before_process_user, $before_process_sys) = ticks_process(); my @threads; for my $i (0 .. 8) { my $t = threads->create(\&dowork); push @threads,$t } $_->join() foreach @threads; my ($after_all_user, $after_all_sys) = ticks_all(); my ($after_process_user, $after_process_sys) = ticks_process(); #(note: changing perl defaults for print) $, = " "; #put spaces between output fields $\ = "\n"; #add LF to end of lines by default print 'delta process: user:', $after_process_user - $before_process_us +er, ' sys:', $after_process_sys - $before_process_sys; print 'delta all: user:', $after_all_user - $before_all_user, ' sys: ', $after_all_sys - $before_all_sys;
    The results:
    > export TIMEFORMAT="%2Rsec %2Uusr %2Ssys (%P%% cpu)" > time python delta process: user: 9263 sys: 2987 delta all: user: 6034 sys: 2178 67.35sec 92.64usr 29.89sys (181.94% cpu) > time perl /tmp/pticks delta process: user: 2917 sys: 3 delta all: user: 2926 sys: 25 3.36sec 29.20usr 0.03sys (870.05% cpu) --- For 9 threads: lang #thrds #coresuse %efficency python 9 1.82 20.2% perl 9 8.70 96.7%
    I tried to use as close to same semantics as the python program. Even used python indentation where practical (I did split the prints at the end... something python seems to have problems with...)
Declarative Objects
No replies — Read more | Post response
by einhverfr
on Feb 27, 2014 at 09:29

    In a recent blog post I put together, I added a code sample I am expecting to release in LedgerSMB 1.5 (code under the GPL v2+, etc). The sample shows what I think is really cool about Perl 5 as a language, namely the ability to change the semantics enough to build dialects for specific things in the code.

    This example extends some of the things that Moose or Moo does to show declaratively defined object methods (in this case wrapping a service locator for PostgreSQL stored procedures.

    package LedgerSMB::Currency; use Moose; with 'LedgerSMB::PGOSimple::Role', 'LedgerSMB::MooseTypes'; use PGObject::Util::DBMethod; sub _set_prefix { 'currency__' } has id => (is => 'rw', isa => 'Int', required => '0'); has symbol => (is => 'ro', isa => 'Str', required => '1'); has allowed_variance => (is => 'rw', isa => 'LedgerSMB::Moose::Number', coerce => 1, required => 1); has display_precision => (is => 'rw', isa => 'Int', required => '0'); has is_default => (is => 'ro', isa => 'Bool', required => '0'); dbmethod list => (funcname => 'list', returns_objects => 1 ); dbmethod save => (funcname => 'save', merge_back => 1); dbmethod get => (funcname => 'get', returns_objects => 1, arg_list => ['symbol']); dbmethod get_by_id => (funcname => 'get_by_id', returns_objects => 1, arg_list => ['id']); __PACKAGE__->meta->make_immutable;

    This code allows me to do something like:

    my $usd = LedgerSMB::Currency->get('USD'); my @currencies = LedgerSMB::Currency->list; $usd->{allowed_variance} = 0.2; $usd->save;
    These get mapped back to stored procedures with names like "currency__get" and "currency__list" with argument names mapped in dynamically based on stored procedure argument names. script for Windows
4 direct replies — Read more / Contribute
by golux
on Feb 26, 2014 at 16:11
    This script came about by accident, when my Windows laptop somehow got its PATH temporarily messed up and couldn't resolve the "ipconfig" command. I'm used to typing "ifconfig" in Linux so I wrote this "" script for Windows; it's essentially a wrapper which reformats ipconfig's output in an easier-to-read format, and by default discards interfaces which are down or apply to VMs (VMware virtual machines).

    It also gives useful information that the simple form of ipconfig lacks (eg. the adapter's MAC address -- to get it you have to use "ipconfig/all" which spews out even more information to wade through). Plus, you can easily spot from the "Connected" line in the header the indices of connected interfaces (when -a or -v is supplied).

    Here's an output comparison, where less lines is arguably better when you're trying to get device information quickly:

    ipconfig ......... 57 lines ipconfig/all ..... 121 lines (!) ...... 19 lines

    Now that I'm using the script all the time I've added a feature to disable/reenable the network device by adding the argument ~N, where N is the index of the device displayed. This saves the hassle of having to open several dialog boxes to get to the network adapter settings, just to be able to cycle an interface that's down for some reason.

    #!/usr/bin/perl -w # # Displays currently connected network interfaces. # Lets you DISABLE/REENABLE an interface (eg. if it's not responding) # # 2014-02-26 golux -- created. ## ############### ## Libraries ## ############### use strict; use warnings; use File::Basename; use Data::Dumper; use Getopt::Long; ################## ## User-defined ## ################## my $ipconfig = 'C:\Windows\System32\ipconfig.exe'; my $netsh = 'C:\Windows\System32\netsh.exe'; my $maxwidth = 12; my $re_addr = qr/^(\d+)[.](\d+)[.](\d+)[.](\d+)(?:)?$/; my $re_vm = qr/VMware Network Adapter/i; my $re_dots = qr/[\s.]*:\s*/; my $re_if = qr/^\s*([\sa-z0-9]+):\s*$/i; my $re_ip_addr = qr/IP Address:\s*(\d+[.]\d+[.]\d+[.]\d+)/i; # Order of tags presented my $a_items = [qw[ desc dhcp state mac addr addr6 mask gate dns ]]; # Label used for each tag my $h_label = { 'desc' => 'Desc', 'state' => 'State', 'dhcp' => 'DHCP', 'mac' => 'MAC', 'addr' => 'IP Addr', 'addr6' => 'IPv6 Addr', 'mask' => 'Mask', 'gate' => 'Gateway', 'dns' => 'DNS Suffix', }; # Regex used to capture the value for each tag my $h_regex = { 'desc' => qr/^\s*Description${re_dots}(.+)/i, 'state' => qr/^\s*Media State${re_dots}(.+)/i, 'dhcp' => qr/^\s*Dhcp Enabled${re_dots}(\S+)/i, 'mac' => qr/^\s*Physical Address${re_dots}(\S+)/i, 'addr' => qr/^\s*IP(?:v4)? Address${re_dots}(\S+)/i, 'addr6' => qr/^\s*IPv6 Address${re_dots}(\S+)/i, 'mask' => qr/^\s*Subnet Mask${re_dots}(\S+)/i, 'gate' => qr/^\s*Default Gateway${re_dots}(\S+)/i, 'dns' => qr/^\s*Connection-specific DNS Suffix${re_dots}(\S+)/i +, }; ############# ## Globals ## ############# my $b_all = 0; my $b_vms = 0; my $b_help = 0; ################## ## Command-line ## ################## Getopt::Long::Configure("bundling"); my $go = GetOptions( "a" => \$b_all, "v" => \$b_vms, "h" => \$b_help, ); ################## ## Main Program ## ################## $| = 1; my $iam = basename $0; $b_help and give_help(); my $a_args = [ @ARGV ]; my $a_info = get_config_info(); if (@$a_args > 0) { change_inteface_states($a_info, $a_args); $a_info = get_config_info(); } show_basic_info(); show_interface_info($a_info); ################# ## Subroutines ## ################# sub fatal { my ($msg) = @_; my $lnum = (caller)[2]; my $text = "($iam) FATAL[$lnum]: $msg"; die "$text\n"; } sub give_help { my $syntax = qq{ : Syntax: $iam [switches] [command ...] : : This program shows the currently connected network interfac +es. : : To cycle a network interface #N (disable, then enable it a +gain), : use the command '$iam ~N'. : : Switches : -a ... display all interfaces (even disconnected ones) : -v ... display virtual (ie. VMware) interfaces : -h ... display help message and exit }; $syntax =~ s/(^\s+:)|((?<=\n)\s+:)|(\s+$)//g; die "$syntax\n"; } sub get_config_info { chomp(my @lines = `$ipconfig /all`); my $a_info = [ ]; my $h_if = { }; HANDLE_LINE: foreach my $line (@lines) { $line =~ /^\s*$/ and next; if ($line =~ /$re_if/) { my $if = $1; (my $name = $if) =~ s/^Ethernet adapter\s*//i; $h_if = { 'if' => $if, 'name' => $name }; push @$a_info, $h_if; next; } foreach my $item (@$a_items) { if ($line =~ /$h_regex->{$item}/) { $h_if->{$item} = $1; next HANDLE_LINE; } } } return prune_results($a_info); } sub prune_results { my ($a_info) = @_; my $a_pruned = [ ]; for (my $i = 0; $i < @$a_info; $i++) { my $idx = $i + 1; my $h_if = $a_info->[$i]; my $addr = $h_if->{'addr'} || ""; my $name = $h_if->{'name'} || ""; my $b_is_vm = ($name =~ /$re_vm/)? 1: 0; my $b_conn = 0; $addr =~ s/\(Preferred\)//; if ($addr =~ /$re_addr/) { ($1 or $2 or $3 or $4) and $b_conn = 1; } $h_if->{'conn'} = $b_conn; if ($b_all or ($b_conn and ($b_vms or !$b_is_vm))) { push @$a_pruned, $h_if; } } return $a_pruned; } sub show_basic_info { my $a_conn = [ ]; for (my $i = 0; $i < @$a_info; $i++) { my $idx = $i + 1; my $h_if = $a_info->[$i]; my $b_conn = $h_if->{'conn'} || 0; $b_conn and push @$a_conn, $idx; } my $conn = (0 == @$a_conn)? "(none)": join(", ", @$a_conn); print "\n"; my $cname = $ENV{'COMPUTERNAME'} || ""; my $domain = $ENV{'ComputerDomain'} || ""; my $user = $ENV{'USERNAME'} || ""; print " ------------------------------------------------\n"; $cname and print " Computer .... $cname\n"; $domain and print " Domain ...... $domain\n"; $user and print " User ........ $user\n"; $conn and print " Connected ... $conn\n"; print " ------------------------------------------------\n"; print " Type '$iam -h' for help\n"; print "\n"; } sub show_interface_info { my ($a_info) = @_; my $space = " "; for (my $i = 0; $i < @$a_info; $i++) { my $h_if = $a_info->[$i]; my $idx = $i + 1; my $if = $h_if->{'if'}; printf " #%d [$if]\n", $idx; foreach my $item (@$a_items) { if (my $val = $h_if->{$item} || "") { ($item eq 'mac') and $val =~ s/-/:/g; my $label = $h_label->{$item} || " "; $label or fatal("No label found for item '$item'"); my $dots = "." x ($maxwidth - length($label)); printf "$space %s %s %s\n", $label, $dots, $val; } } print "\n"; } } sub change_inteface_states { my ($a_info, $a_args) = @_; my $nifs = @$a_info; foreach my $arg (@$a_args) { if ($arg !~ /^~(\d+)$/) { print "Invalid arg '$arg' ignored\n"; } else { my $idx = $1; if ($idx < 1 or $idx > $nifs) { print "Skipping interface '$idx' (not in range 1-$nifs +)\n"; } else { my $h_if = $a_info->[$idx-1]; my $name = $h_if->{'name'}; cycle_network_interface($name); } } } print "\n\n"; } sub cycle_network_interface { my ($name) = @_; print "Type [RETURN] to DISABLE, then ENABLE interface '$name':"; <STDIN>; my $netsh_dis = qq{interface set interface "$name" DISABLED}; my $netsh_en = qq{interface set interface "$name" ENABLED}; my $netsh_show = qq{interface ip show addresses "$name"}; print "Command: netsh $netsh_dis\n"; system("$netsh $netsh_dis 1>nul 2>nul"); print "Command: netsh $netsh_en\n"; system("$netsh $netsh_en 1>nul 2>nul"); my $ntries = 32; my $addr = ""; print "Renewing IP address "; while ($ntries-- > 0) { print "."; chomp(my @results = `$netsh $netsh_show`); map { /$re_ip_addr/ and $addr = $1 } @results; $addr and last; select(undef, undef, undef, 0.25); } print "\n"; $addr or fatal("Failed to reenable interface '$name'"); }

    say  substr+lc crypt(qw $i3 SI$),4,5
Remove unwanted MP3 tags
2 direct replies — Read more / Contribute
by walto
on Feb 16, 2014 at 13:35
    Sometimes mp3 files come with a plethora of tags. Some of them contain unnecessary information.
    Here is a script that removes unwanted tags. The unwanted tags are stored in an array.

    10 years ago I joined the monastery. Today I received a HappyMonks day greeting. That's a nice idea, and a thought it is a good occasion to share a script I wrote recently.

Add your 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?

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

    How do I use this? | Other CB clients
    Other Users?
    Others browsing the Monastery: (8)
    As of 2014-12-20 04:39 GMT
    Find Nodes?
      Voting Booth?

      Is guessing a good strategy for surviving in the IT business?

      Results (95 votes), past polls