Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine

The Monastery Gates

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

Donations gladly accepted

If you're new here please read PerlMonks FAQ
and Create a new user.

New Questions
split (grep)
2 direct replies — Read more / Contribute
by tbone654
on Oct 23, 2014 at 15:52

    This is driving me crazy... I'm ultimately trying to read in two lists, one with a single column of ordered names... The second list is a column of names with a comma separated (this test script is using semi-colons) value after the name...
    If I were able to do this in unix I would be:

    grep -f file1 file2
    Which is ok, but file1 loses it's order to file2, and what I really want to do is print values from file2 next to the order in file1... so I need to split off values and print the results next to the members of file1 where there is a match...
    But it seems like today I'm too stupid to figure out how to do the split command correctly... Or, other... I could just print the line from list2, but there could be many values and I need to split them out to do math on them after I figure out the problem with split... perldoc -f split tells me it's returning the number of times each line succeeds, where I need to be able to manipulate the results. I've been searching the site for something similar, with no success. Thank you for any help in advance.

    my $a; my @foo = qw/tom steve bill roger bob/; my @bar = qw/roger;99 steve;56 ted;88 tom;54/; for($a=0;$a<@foo;$a++) { printf("%s %s\n",$foo[$a],grep(/$foo[$a]/,@bar)); } print "----\n"; for($a=0;$a<@foo;$a++) { # printf("%s\n", grep(/$foo[$a]/,@bar) ); printf("%s\n", (split /;/, grep(/$foo[$a]/,@bar))[0] ); } --output before split-- tom tom;54 steve steve;56 bill roger roger;99 bob ---- tom;54 steve;56 roger;99 --output using split-- tom tom;54 steve steve;56 bill roger roger;99 bob ---- 1 1 0 1 0
Word OLE add Comments
3 direct replies — Read more / Contribute
by Anonymous Monk
on Oct 23, 2014 at 12:27

    Dear Monks

    I know that my question is not so relevant for Perl, but I really can't find any other information on the Web, so I hope to fine a monk wanting to help me out.

    I need to insert in a Word document comments for words matching a RegExp. So far I put together the following script which is working fine. It highlight all instances of that word in the document. What I'd like to do is to add a comment for that words. I don't find any info for that. Can you point me to the right direction?

    #!/usr/bin/perl use strict; use warnings; use Win32::OLE; use Win32::OLE::Const 'Microsoft Word'; $Win32::OLE::Warn = 3; my $word = get_word(); $word->{Visible} = 1; my $doc=$word->Documents->Open('D:/test.docx'); my $WordToLookup="xy"; FindAndReplace(); sub FindAndReplace{ $word->Selection->HomeKey(wdStory); $word->Selection->Find->{'Text'}=$WordToLookup; $word->Selection->Find->Replacement->{'Highlight'}=1; $word->Selection->Find->Execute({Replace=>wdReplaceAll}); } sub get_word { my $word; eval { $word = Win32::OLE->GetActiveObject('Word.Application'); }; die "$@\n" if $@; unless(defined $word) { $word = Win32::OLE->new('Word.Application', sub { $_[0]->Quit +}) or die "Oops, cannot start Word: ", Win32::OLE->LastError, "\n"; } return $word; }
count down with while loop
4 direct replies — Read more / Contribute
by rshoe
on Oct 23, 2014 at 11:51
    I need some help on a problem I an trying to solve. My program should display multiples of a chosen integer between 200 and 100, For example, if user enters 15, output should be 195 180 165... The program must use a while loop If anyone can help me I would appreciate it. Thanks, Randy Here is my code
    #!c:\Dwimperl\perl\bin\perl.exe use strict; use warnings; #### prompt a user to enter an integer print "Enter an integer "; my $integer = <STDIN>; chomp $integer; my $i = 199; ### use either a while loop or an until loop to count down from 200 to + 100 while($i >= 99){ ### display all multiples of the integer in this range of (200 - +100) print $i - $integer . "\n"; --$i; }
perl threads & memory
5 direct replies — Read more / Contribute
by FrankyGT
on Oct 23, 2014 at 07:32

    What's wrong with perl threads?

    If I run this code :

    use threads; sub my_sub() { return 1; } while (1) { my $thr=threads->create(\&my_sub); my @res=$thr->join(); }

    Within 5 minutes my heap has grown to over 50MB and keeps growing...

Delete "/" in a string
4 direct replies — Read more / Contribute
by WTem
on Oct 22, 2014 at 22:28

    Hi Monks, I just subscribed here a few minutes ago seeking for help >< I am recently getting into perl for my work since a couple of weeks now. And like not super smart people, there is at least a first time when we need help for something dump ... The problem I'm into is this :

    As parameters of a command that I created with perl, the user enter an interface name of a cisco router and his IP adress, then I put them an a variable like $ip = and $interface = POS1/0/0

    Now what I want to do is to create a .txt file as follow : $filename = "$ip--$interface.txt" but without "/" (obviously). As a result I should have a file named :

    In short, how can I change $interface = "POS1/0/0" into $interface = "POS100" ??

    Looks simple saying like this but I really need help in this. Thank you very much for your time and help ^^

Forking Perl5 with Microperl++?
2 direct replies — Read more / Contribute
by rje
on Oct 21, 2014 at 10:27

    "If I were to implement a language now, I'd write a very minimal core suitable for bootstrapping. ... Think of a handful of ops. Think very low level. (Think something a little higher than the universal Turing machine and the lambda calculus and maybe a little bit more VMmy than a good Forth implementation, and you have it.) If you've come up with something that can replace XS, stop. You're there. Do not continue. That's what you need." (Chromatic, January 2013)

    This is in Chromatic's response to Moe, which sounds -Ofun and seems like a good idea.

    And now that I've crawled out from under my rock, I see microperl, an ancient tool included with 5.8. Alright, I don't recall ever hearing about microperl. It's not in my copy of the Programming Perl book, and that sucker is a thousand pages.

    And lately, haven't I seen grumblings about the insularity and stubborn bikeshedding nature of the Perl community?

    So how about this. Microperl isn't the "handful of ops" that Chromatic is suggesting, and it ain't XS, but it's tiny and, well, it's Perl. Therefore, what are the issues around forking and modifying microperl (oh so gently) to bootstrap a variant of Perl5? I mean, it's already written, and it's tiny -- minimal, if Simon is to be believed. I mean, the thing built in a 300k footprint when compiled with a proper optimizer. So what's not to like?

    So I re-ask my question. Doesn't microperl seem to be at least halfway to a bootstrap up to a useful and somewhat regularized, normalized, unpackable, what-have-you-able variant of Perl5?

    Just for reference, here's a sample microperl script written in zentara's discussion. It seems pretty handily powerful for being a tiny subset of perl. Is there documentation for microperl?

Recursively executed function in regex RHS, AKA "wait, why does this work?"
5 direct replies — Read more / Contribute
by Cody Fendant
on Oct 21, 2014 at 07:21

    I was playing around with some code to render a kind of templated HTML, and I came up with the code below.

    The HTML contains special markup, <include id="n"> where n is an integer. These are looked up in a db but here they're just returned by a sub to make this question simple and self-contained. In the example below, there are nested includes where include 3 contains a reference to include 4 and 4 contains a reference to 5.

    I did the rendering by re-calling the rendering function, inside the rendering function as the right-hand side of a regular expression.

    My question is—why does this work? How come it renders all the way down instead of stopping after the first level? I thought it would need some kind of while loop to keep it rendering until it had processed all possible nested includes.

    #!/usr/local/bin/perl print render(1); sub render { my $id = shift; $HTML = return_html($id); $HTML =~ s/<include id="(\d+)">/render($1)/eg; return $HTML; } ### this sub is only here to mimic database lookups sub return_html { my $id = shift; if ( $id == 1 ) { return '<html> <head> <include id="2"> <title>hello world</title> </head> <body> <div class="container"> <h1>Hello world</h1> <include id="3"> </div> </body> </html>'; } if ( $id == 2 ) { return '<link rel="stylesheet" href="foo.css">'; } if ( $id == 3 ) { return '<div id="footer">copyright <include id="4"></div>'; } if ( $id == 4 ) { return '2014 <include id="5">'; } if ( $id == 5 ) { return 'and 2015'; } }
No need to escape right brace in regex
2 direct replies — Read more / Contribute
by syphilis
on Oct 21, 2014 at 00:13
    In recent versions of blead (including current 5.21.5) I get:
    C:\>perl -le "$_ =~ /sub mymy{ }/;" Unescaped left brace in regex is deprecated, passed through in regex; +marked by <-- HERE in m/sub mymy{ <-- HERE }/ at -e line 1. C:\>
    That's easily fixed:
    C:\>perl -le "$_ =~ /sub mymy\{ }/;" C:\>
    But why not also (or instead) deprecate the unescaping of the *right* brace ?

Human-readable date format strings
3 direct replies — Read more / Contribute
by thewebsi
on Oct 20, 2014 at 22:28

    I'd like to work with human-readable date format strings - ie, allow the user to select the date format for input and output using a human-readable string such as 'yyyy-mm-dd'.

    Unfortunately, the popular date manipulation strftime()/strptime() functions from POSIX and Time::Piece use a non-human-friendly '%X' format. In my search, I found Time::Format::time_format(), and this does exactly what I want for output (strftime), but there is no input (strptime) equivalent.

    Barring any better options, I'll probably write a regex block to convert format strings from a human-readable format to the POSIX format so I can use the standard functions. Before I embark on that however, does anyone have other suggestions? Thanks.

    Edit: To clarify, instead of POSIX::strftime ( '%Y %m %d', localtime() ), I'd like to use SomeModule::SomeFunction ( 'yyyy-mm-dd', localtime() ), as Time::Format::time_format() does, but also need support for strptime().

Problem with monitoring running tasks
3 direct replies — Read more / Contribute
by cariddiEMC
on Oct 20, 2014 at 13:04

    Hi, I am pretty new to perl, so please be understanding. Below is a perl subroutine, that I inherited, that is used to run a set of "X" tests simultaneously. This subroutine is called by a script that I will call that takes a file containing a list of tests and runs them. Periodically I am finding that for some reason or another 1 or more of the tests we run do not complete. Each test has a timeout that will terminate the test if exceeds the time limit.

    When I use system monitor to see what is going on, none of my tests are running anymore, but I see 2 or more instances of running. Every instance of, except 1, that are running, have a pid that relates to the test or tests that have not completed. I am assuming that pid of the process that I cannot match up is the pid of the terminal window where I originally ran from.

    Can somebody help me find what is wrong? I have done a lot of reading on waitpid and on the other commands used in the runall subroutine but I have not found any smoking gun.

    Thanks. Mark

    sub runAll { my $self = shift; my $doneThreadsLock : shared = 1; my $testQueueLock : shared = 1; my @workers; for (1..$self->{'maxtasks'}) { push @workers, threads::async { $SIG{'INT'} = sub { my $tid = threads->tid(); # Tell user we've been terminated if (exists $self->{'runningTasks'}->{$tid}) { my $worker_task = $self->{'runningTasks'}->{$t +id}; my $exec_name = getExecName(join(" ",@{$worker +_task->{'command'}})); my $pid = $worker_task->{'pid'}; kill(-12, $pid); # print "Worker $tid >> Waiting$exec_name pid: +$pid\n"; waitpid($pid, 0); # print "Worker $tid >> Done $exec_name pid: $p +id\n"; $worker_task->{'endTime'} = time(); } { lock $doneThreadsLock; $self->{'doneThreads'}->enqueue($tid); } print "INT: Worker $tid exiting\n"; threads->exit(); }; my $tid = threads->tid(); my $rc; my $continueProcessing = 1; my $worker_task; while ($continueProcessing) { { lock $testQueueLock; $worker_task = $self->{'testQueue'}->dequeue(); } if(!$worker_task) { $continueProcessing = 0; next; } my $exec_name = getExecName(join(" ",@{$worker_task->{ +'command'}})); chdir ($worker_task->{'workdir'}); print "Running: $exec_name\n"; $worker_task->{'startTime'} = time(); $self->{'runningTasks'}->{$tid} = $worker_task; my $cmd = join(" ", @{$worker_task->{'command'}}); my $pid = fork; # if we are child process, pid will be 0 otherwise we +are the master if ($pid == 0) { # print "pid = 0, $exec_name running as child proce +ss.\n"; my $logfile = FileHandle->new; $logfile->open("> $worker_task->{'log'}"); $logfile->autoflush(1); open(STDOUT, '>&=' . $logfile->fileno); open(STDERR, '>&=' . $logfile->fileno); select STDERR; $| = 1; # make unbuffered select STDOUT; $| = 1; # make unbuffered $logfile->close; # print "Execing child process $exec_name pid($pid) +.\n"; { lock $doneThreadsLock; $self->{'doneThreads'}->enqueue($tid); } setpgrp; exec("$cmd"); exit(1); } $worker_task->{'pid'} = $pid; my $child_status; # print "Waiting for $exec_name $pid to exit\n"; while (waitpid($pid, POSIX::WNOHANG) != -1) { $child_status = $?; sleep(1); } # print "Done waiting for $exec_name $pid to exit\n"; $worker_task->{'endTime'} = time(); $worker_task->{'status'} = $child_status; # print "Done waiting for $exec_name $pid to exit statu +s ($child_status)\n"; } { lock $doneThreadsLock; $self->{'doneThreads'}->enqueue($tid); } threads->exit(); }; } print "all tasks queued, Now waiting for tasks to exit before queu +ing more.\n"; { lock $testQueueLock; $self->{'testQueue'}->enqueue(undef) for @workers; } my $threads_exited = 0; my $stop_done = 0; while ($threads_exited < $self->{'maxtasks'}) { my $tid; { lock $doneThreadsLock; $tid = $self->{'doneThreads'}->dequeue_nb(); } if (defined($tid)) { threads->object($tid)->join(); $threads_exited++; print "threads_exited($threads_exited) maxtasks:($self->{' +maxtasks'}).\n"; } else { if ($self->{stop} && !$stop_done) { $stop_done = 1; foreach my $thr (threads->list()) { $thr->kill('INT'); } } else { sleep(1); } } } }
combining emacs' cperl-mode formatting with Perltidy
1 direct reply — Read more / Contribute
by LanX
on Oct 20, 2014 at 08:33

    I love the instant formatting features emacs gives me when typing Perl, but they can't cope with perltidy's detailed control.

    So I would like to run perltidy from time to time to update my text buffer (anything less frequent than with every return hit)

    Problem is to have a compatible and "tolerant" config, where both formatter don't start messing the result of the other one.

    Did anyone already try to achieve this somehow?

    Cheers Rolf

    (addicted to the Perl Programming Language and ☆☆☆☆ :)

Using Shift with Parameters in a subroutine
6 direct replies — Read more / Contribute
by perlron
on Oct 20, 2014 at 05:00
    Hi ,

    Is there any way to compress both these statements to one line ? It would only seem rational that we have a way to do so, especially if i am passing 10 references to my subroutine.

    sub foo ( my $query_ref = shift(@_); my $session_ref = shift(@_); #do something return \$someref; }

    Not directly related to the above, but going through the man pages , i see there is no formal parameter support , at least in perl 5.10.1 (which is my customer version ) . I heard we have subroutine signature support in perl5.20. if so can you point me to the man pages for that ?

New Meditations
Refactoring Perl5 with Lua
No replies — Read more | Post response
by rje
on Oct 21, 2014 at 14:31

    WARNING: It may be that I'm simply thinking about Parrot in a different way...

    If you've read my previous post on microperl, then you're sufficiently prepared to take this post with a grain of salt. As a brief summary, I'll re-quote something Chromatic wrote to start me thinking about this problem in general:

    "If I were to implement a language now, I'd write a very minimal core suitable for bootstrapping. ... Think of a handful of ops. Think very low level. (Think something a little higher than the universal Turing machine and the lambda calculus and maybe a little bit more VMmy than a good Forth implementation, and you have it.) If you've come up with something that can replace XS, stop. You're there. Do not continue. That's what you need." (Chromatic, January 2013)

    Warning: I've never written a VM or a bytecode interpreter. I have written interpreters and worked with bytecodes before (okay, a 6502 emulator, but that's basically a bytecode interpreter, right?) Just remember that I'm not posting from a position of strength.

    So I found the Lua opcode set, and it seems a good starting point for talking about a small, though perhaps not minimal, Turing machine that seems to do much of what Chromatic was thinking about... except for XS, which I still haven't wrapped my head around.

    Lua has a register-based 35 opcode VM with flat closures, threads, coroutines, incremental garbage collection... and manages to shoehorn in a tail call, a "for" loop, and a CLOSURE for goodness' sake. And some of those opcodes could be "macros" built on top of other opcodes, rather than atomic opcodes (only if speed were unimportant): SUB, MUL, DIV, POW, LE.

    Again, a disclaimer: I haven't been in a compiler construction class for 25 years, and my career has typically been enterprise coding, data analysis, and tool scripting. Regardless, a small opcode set seems to me to be important for portability. And... 35 codes... well, that's dinky.

    I don't assume that Lua's codes are sufficient for Perl... things are likely missing or just not quite right for Perl. But I have to start somewhere, right? And I figure some of you have the right Domain Knowledge to shed some light on the subject. Right?

    There's lots of neat notes in the aforementioned Lua design doc, written in a clear and concise manner. And now for a brief glance at Lua's opcodes:

On optimizing nested loops
2 direct replies — Read more / Contribute
by FloydATC
on Oct 19, 2014 at 06:05

    While working on a complex script doing lookups and searches on a dozen arrays of hashes (each array representing a relational database table) I stumbled across an extremely simple improvement that instantly gave almost twice the performance.

    The original loop looked like this:

    sub filter { my $where = shift; my @in = @_; # This class method is used to filter an array of hashrefs against a + set of criteria defined in $where. # Example: # @matching_hosts = filter( { site => 56, type => 4 }, @all_hosts) +; # In this example, @matching_hosts will only contain those hashrefs +that would return TRUE for the following code: # ($_->{'site'} eq '56' && $_->{'type'} eq '4') # Note that the "eq" and "&&" are implied; no other operators are su +pported. # The order of the array is not affected. my @out = (); foreach my $record (@in) { my $keep = 1; foreach my $field (keys %{$where}) { unless ($record->{$field} eq $where->{$field}) { $keep = 0; last; } push @out, $record if $keep; } } return @out; }

    The rewritten loop looks like this:

    sub filter { my $where = shift; my @in = @_; # This class method is used to filter an array of hashrefs against a + set of criteria defined in $where. # Example: # @matching_hosts = filter( { site => 56, type => 4 }, @all_hosts) +; # In this example, @matching_hosts will only contain those hashrefs +that would return TRUE for the following code: # ($_->{'site'} eq '56' && $_->{'type'} eq '4') # Note that the "eq" and "&&" are implied; no other operators are su +pported. # The order of the array is not affected. my @out = (); # Make one pass per match term foreach my $field (keys %{$where}) { my $value = $where->{$field}; @out = grep { $_->{$field} eq $value } @in; @in = @out; # Prepare for next pass (if any) } return @out; }

    The running times of actual reports dropped from over 4 seconds to less than 2 seconds. Some of that improvement obviously came from using the built-in grep{} function instead of manually checking each value and push()'ing hashrefs to the @out array, but I didn't expect that much of an improvement.

    There had to be a different explanation, and that got me thinking about the cost of setting up and executing a foreach() loop:

    $ cat foreach_inner #!/usr/bin/perl use strict; use warnings; foreach my $foo (1 .. 3) { foreach my $bar (1 .. 10000000) { my $pointless = "$foo.$bar"; } }
    $ time ./foreach_inner real 0m8.975s user 0m8.954s sys 0m0.013s
    $ cat foreach_outer #!/usr/bin/perl use strict; use warnings; foreach my $foo (1 .. 10000000) { foreach my $bar (1 .. 3) { my $pointless = "$foo.$bar"; } }
    $ time ./foreach_outer real 0m14.106s user 0m14.092s sys 0m0.003s

    Both test scripts do the exact same amount of (pointless) work, the difference between the two scripts is that 'foreach_inner' has to execute 9999997 more foreach() loops than 'foreach_outer'.

    Sometimes, even a seemingly pointless improvement can make a significant difference if made in the right place.

    Now, the way filters are specified in $where is pretty much nailed down because that hashref is built and used in a lot of different contexts. I am still looking for a way to express the whole thing as a single grep{} block to eliminate the looping altogether. Maybe tomorrow.

    -- FloydATC

    Time flies when you don't know what you're doing

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 scrutinizing the Monastery: (8)
As of 2014-10-24 12:19 GMT
Find Nodes?
    Voting Booth?

    For retirement, I am banking on:

    Results (131 votes), past polls