Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris

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
Catching errors (II).
1 direct reply — Read more / Contribute
by Steve_BZ
on Oct 30, 2014 at 10:08

    Hi Guys,

    This carries on from Catching errors.. I took the advice of saberworks and instituted a custom die and warn routine like this:

    BEGIN{ $SIG{__DIE__} = \&customDieFatalErr; $SIG{__WARN__} = \&customWarning; }

    So now I get any uncaught perl errors and warnings in my email. It is totally wonderful. Errors are reported automatically by the failing system, and can be fixed before the user even complains!

    But What about the dreaded segfault?

    Guys, what should I do?

    I'm thinking about having a calling routine (a Perl app or bashscript) that catches the error and then reports it to me before automatically restarting the application. What do you think?



same encrypt word ?
3 direct replies — Read more / Contribute
by docofchaos
on Oct 30, 2014 at 06:33
    hi, i'll make the same function on perl who based on this function on php
    function encrypt_text($plain_text, $key){ bin2hex(mcrypt_encrypt(MCRYPT_RIJNDAEL_256, $key, $plain_text, MCRYPT_ +MODE_ECB)); return $encrypt_text; }
    I wrote this but this is not the same result
    use Crypt::Rijndael; use Crypt::CBC; sub chiffrer_string($plain_text, $key){ $key =~ pack('H*', $key); my $cipher = Crypt::CBC->new( -key => $key, -algorithm => 'RIJNDAEL_256', -mode => 'MODE_ECB', -padding => 'null', ) || die "Couldn't create CBC object"; my $cipher_text = $cipher->encrypt($plain_text); my $cipher_block = unpack ("H*", $cipher_text); return $cipher_block;
    have you got any idea ?
Undocumented join() feature, now defunct?
3 direct replies — Read more / Contribute
by johngg
on Oct 29, 2014 at 18:55

    I thought it might be useful to have an equivalent to join that could stitch a LIST together with an EXPR that actually varied. Just for fun, and not expecting it to work, I first tried supplying a tied scalar incrementor as the first argument to join but, to my great surprise, it did produce a string with a varying EXPR joining the LIST elements. This code

    use strict; use warnings; use feature qw{ say }; # =========== package Incrementor; # =========== use Tie::Scalar; our @ISA = qw{ Tie::StdScalar }; sub TIESCALAR { my( $pkg, $value ) = @_; $value //= 0; return bless \ $value, $pkg } sub FETCH { my $self = shift; return ${ $self } ++; } package Main; my @arr = qw{ a b c d e }; tie my $inc, q{Incrementor}; say join $inc, @arr; say q{-} x 20; say join $inc, @arr;

    produces this output

    a1b2c3d4e -------------------- a6b7c8d9e

    Note that the invocation of join seems to consume the first iteration before actually constructing the string. The documentation says

    Joins the separate strings of LIST into a single string with fields separated by the value of EXPR, and returns that new string.

    and the wording looks the be the same for for all versions. My expectation was that the EXPR would be evaluated once and the invariant result used between every element of the LIST. This doesn't appear to be the case for the following perl versions - 5.8.8, 5.10.1 and 5.14.2 on various Linuxen or Cygwin and 5.16.1 on Windows 7. However, under 5.18.2 on Mint 17 I do get what I was expecting

    a0b0c0d0e -------------------- a1b1c1d1e

    I don't have 5.20 installed anywhere so can't test on that. Is the behaviour of join with a tied scalar prior to 5.18.2 correct but not clearly explained in the documentation or is it a bug that has now been fixed?



Splitting PDFs with PDF::API2
3 direct replies — Read more / Contribute
by Jawle
on Oct 29, 2014 at 14:23
    Hello all,

    I have undertaken the task of learning Perl in the interest of running this script:

    #!/usr/bin/env perl use strict; use warnings; use PDF::API2; my $filename = shift || 'test.pdf'; my $oldpdf = PDF::API2->open($filename); my $newpdf = PDF::API2->new; for my $page_nb (1..$oldpdf->pages) { my ($page, @cropdata); $page = $newpdf->importpage($oldpdf, $page_nb); @cropdata = $page->get_mediabox; $cropdata[2] /= 2; $page->cropbox(@cropdata); $page->trimbox(@cropdata); $page->mediabox(@cropdata); $page = $newpdf->importpage($oldpdf, $page_nb); @cropdata = $page->get_mediabox; $cropdata[0] = $cropdata[2] / 2; $page->cropbox(@cropdata); $page->trimbox(@cropdata); $page->mediabox(@cropdata); } (my $newfilename = $filename) =~ s/(.*)\.(\w+)$/$1.clean.$2/; $newpdf->saveas('$newfilename'); __END__

    I have created the program and am able to launch it, however I am very confused as to what I need to replace with my file and directory. For ex: should I insert my filename in line 6 in the brackets of ($filename)?

Telnet to server
3 direct replies — Read more / Contribute
by Kedar_Bhatia
on Oct 28, 2014 at 11:06
    I am trying to login to a route server using below script when i execute my script it just doesnt do anything. I am doing this on a linux machine, idealy i should see a login prompt of the router.
    use Net::Telnet::Cisco; my $session = Net::Telnet::Cisco->new(Host => '', Port => +'23', Timeout =>'100');
Install of Locale:gettext failing due to missing libintl
1 direct reply — Read more / Contribute
by T-Fen
on Oct 28, 2014 at 08:20

    I have perlbrew installed and am attempting to install Locale:gettext with cpanm. I'm seeing the following error (appears libintl is either not found or not installed):

    cpanm (App::cpanminus) 1.7014 on perl 5.020001 built for darwin-2level Work directory is /Users/trey/.cpanm/work/1414409291.13907 You have make /usr/bin/make You have /usr/local/bin/wget You have /usr/bin/tar: bsdtar 2.8.3 - libarchive 2.8.3 You have /usr/bin/unzip Searching Locale::gettext on cpanmetadb ... --> Working on Locale::gettext Fetching +gz -> OK Unpacking gettext-1.05.tar.gz Entering gettext-1.05 META.yml/json not found. Creating skeleton for it. Configuring gettext-1.05 Running Makefile.PL checking for gettext... no checking for gettext in -lintl...gettext function not found. Please in +stall libintl at Makefile.PL line 18. no -> N/A -> FAIL Configure failed for gettext-1.05. See /Users/trey/.cpanm/work +/1414409291.13907/build.log for details.

    Would someone be able to direct me how to fix?


s/// don't delete matching phrase
8 direct replies — Read more / Contribute
by ChevLucas
on Oct 28, 2014 at 08:19
    Hi, I need to delete all html tags from html file. First I read my file into one variable and then I delete tags by code:
    while ( $file =~ /(<[^>]*>)/g ) { # print "'$1'\n"; $file =~ s/$1//g; }
    It works fine, but can not cope with some expression, eg.: '<?xml version="1.0" encoding="UTF-8"?>' Any idea?
How to allocate a struct?
3 direct replies — Read more / Contribute
by dissident
on Oct 28, 2014 at 07:41

    I am a novice and try to use structs. However, I seem unable to find out how to allocate one. Having spent several hours reading the perl documentation, the Class::Struct documentation and searching the webs, I fearfully decided to approach the sacred halls of Perl Monastery.

    Could a fellow monk please help a novice find out how what is wrong with the following script?

    use strict; use warnings; use Class::Struct; # include <structs> struct( document => { fileID => '$', # $ = scalar = int filename => '@', # @ = array (of char) = string tags => '@' # tags - array of strings }); # all of these three attempts to allocate memory fail: #my $doc = document->new( ); # produces: Can't locate object metho +d "fileID" via package "doc" (perhaps you forgot to load "doc"?) at t line 18. #my $doc = new( 'document'); # produces: Undefined subroutine &mai +n::new called at line 12. #my $doc = new( document); # produces: Bareword "document" not a +llowed while "strict subs" in use at line 13. my $doc = <WhatGoesHere?> # Hopefully a Perl saint knows what g +oes here... doc->fileID( 123 ); doc->filename( 'SampleFileName' ); doc->tags( 'tag1', 'tag2', 'tag3' ); print "File ID: ", doc->fileID, "\n"; print "Filename: ", doc->filename, "\n"; print "Tags: ", doc->tags, "\n";

    I already looked into the alternative using associative arrays, but it would be much cleaner and effective to use structs like in C for my purposes...

    So, any idea what the correct spell to allocate a struct could be?

What does return() mean?
4 direct replies — Read more / Contribute
by yistaaa
on Oct 27, 2014 at 17:12
    I'm quite new to perl and there are some confusing things about it that I can't seem to find any information on For example: sub some_thing { return (); } What does that return statement do? Is it a ref to something?
Dive data with automatic array indexing
1 direct reply — Read more / Contribute
by peterp
on Oct 26, 2014 at 22:33


    I have a large dataset in a configuration file which I plan on eventually porting to a more practical format, but for various reasons this will be complex, therefore for now I have to deal with it. Historically, multidimensional data structures have been stored as sets of selector style keys and values. For example: = 0foobar = 0foobaz = 1foo equates to: [ { foo => { bar => '0foobar', baz => '0foobaz' } }, { foo => '1foo' } ]

    The data is parsed by splitting the key into its individual components then running them through Data::Diver. The problem is I sometimes need to add data into the middle of the dataset and as a result have to increment index components within keys below this, which can be tedious to say the least. I decided the easiest quick fix would be to pre-process the keys beforehand and automatically calculate the array indexes. Thus the above dataset would look:

    > = 0foobar <.foo.baz = 0foobaz >.foo = 1foo

    Where '>' means "next index // 0" and '<' means "last index // 0", within scope of the dimension. I wrote the following demo:

    use strict; use warnings; use Data::Diver qw#DiveVal DiveError#; use Data::Dumper qw#Dumper#; $/ = qq#\r\n#; my $state = { }; my $ref = undef; while ( my $line = <DATA> ) { next if ( $line =~ qr#^(\#|\s*$)# ); # ignore line if comment or b +lank. chomp $line; # remove newline. my ( $selector, $value ) = split qr#\s*=\s*#, $line; # (selector)= +(value). todo: unless escaped. next if ( not defined $selector ); # ignore line if no selector. my @selector = split qr#\.#, $selector; # (one).(two).(three)... t +odo: unless escaped. $ref //= ( $selector[0] =~ qr#^([><]|\d+)$# ) ? [ ] : { } ; _dive( $ref, \@selector, $value ); } print Dumper $state, $ref; sub _dive { my ( $ref, $selector, $value ) = @_; return if ( not defined $ref or not defined $selector or not scala +r @$selector ); # return if no ref or no selectees. my @selector_b = qw##; for my $selectee ( @$selector ) { if ( $selectee =~ qr#^([><])$# ) # if incognito selectee. todo +: unless escaped. { my $selector_b = join q#.#, @selector_b; if ( $1 eq q#># ) # incognito selectee is of increment typ +e. { if ( defined $state->{$selector_b} ) # we have seen th +is state before. { push @selector_b, $state->{$selector_b} += 1; # pu +sh current index + 1. } else { push @selector_b, $state->{$selector_b} = 0; # pus +h 0 (first) index. } } elsif ( $1 eq q#<# ) # incognito selectee is of maintain t +ype. { push @selector_b, $state->{$selector_b} //= 0; # push +current index or 0 (first) index. } } else # else non inconito selectee. { push @selector_b, $selectee; # push selectee. } } DiveVal( $ref, @selector_b ) = $value; my ( $error ) = DiveError( ); $error and warn $error; return 1; } __DATA__ >.name = john <.location = uk <.interests.> = programming <.interests.> = cycling >.name = laura <.location = <.interests.> = knitting <.interests.> = tennis <.interests.> = dancing >.name <.location = canada <.interests.>.> = dogs <.interests.<.> = horses <.interests.> = cars # test.error = blah


    $VAR1 = { '2.interests' => 1, '' => 2, '2.interests.0' => 1, '0.interests' => 1, '1.interests' => 2 }; $VAR2 = [ { 'interests' => [ 'programming', 'cycling' ], 'location' => 'uk', 'name' => 'john' }, { 'interests' => [ 'knitting', 'tennis', 'dancing' ], 'location' => '', 'name' => 'laura' }, { 'interests' => [ [ 'dogs', 'horses' ], 'cars' ], 'location' => 'canada', 'name' => undef } ];

    Is this a good approach, or is there a better alternative? Perhaps I should look into extending Data::Diver's DiveRef function? Can my code be improved, I don't mind a bit of golfing, but I'm concerned there could be a particular scenario that I've missed where my code could break?


Perl version issue?
3 direct replies — Read more / Contribute
by T-Fen
on Oct 25, 2014 at 22:06

    Hello perl monks-

    I'm on a Mac and recently upgraded from Mavericks to Yosemite which might be the cause of my current issue.

    I am using mutt with t-prot and getting the following error when attempting to view a message in mutt (which invokes t-prot)

    'Can't locate Locale/ in @INC (you may need to install the Locale::gettext module) (@INC contains: /Library/Perl/5.12 /Library/Perl/5.18/darwin-thread-multi-2level /Library/Perl/5.18 /Network/Library/Perl/5.18/darwin-thread-multi-2level /Network/Library/Perl/5.18 /Library/Perl/Updates/5.18.2 /System/Library/Perl/5.18/darwin-thread-multi-2level /System/Library/Perl/5.18 /System/Library/Perl/Extras/5.18/darwin-thread-multi-2level /System/Library/Perl/Extras/5.18 .) at /usr/local/bin/t-prot line 1147.

    When i do a search for getttext, I see the following:

    /Library/Perl/5.16/darwin-thread-multi-2level/Locale/ /Library/Perl/5.16/darwin-thread-multi-2level/auto/Locale/gettext /Library/Perl/5.16/darwin-thread-multi-2level/auto/Locale/gettext/.pac +klist /Library/Perl/5.16/darwin-thread-multi-2level/auto/Locale/gettext/gett /Library/Perl/5.16/darwin-thread-multi-2level/auto/Locale/gettext/gett +ext.bundle /Previous System/Library/Perl/5.16/darwin-thread-multi-2level/auto/Loc +ale/gettext /Previous System/usr/local/Cellar/gettext/0.19.3/share/doc/gettext/exa +mples/hello-perl /Previous System/usr/local/Cellar/gettext/0.19.3/share/doc/gettext/exa +mples/hello-perl/m4 /Previous System/usr/local/Cellar/gettext/0.19.3/share/doc/gettext/exa +mples/hello-perl/po /usr/local/Cellar/gettext/0.19.3/share/doc/gettext/examples/hello-perl /usr/local/Cellar/gettext/0.19.3/share/doc/gettext/examples/hello-perl +/INSTALL /usr/local/Cellar/gettext/0.19.3/share/doc/gettext/examples/hello-perl +/ /usr/local/Cellar/gettext/0.19.3/share/doc/gettext/examples/hello-perl +/

    So seeing that @INC doesn't appear to look in /Library/Perl/5.16/ I then added the path using:

    $ PERL5LIB=/Library/Perl/5.16/darwin-thread-multi-2level/; export PERL5LIB

    Doing that, I now get this error when trying to view a message with mutt/t-prot:

    'Perl API version v5.16.0 of v5.16.0 does not match v5.18.0 at /System +/Library/Perl/5.18/darwin-thread-multi-2level/ line 217. + + + Compilation failed in req +uire at /usr/local/bin/t-prot line 1147.

    /Library/Perl/ contains a /5.16 and a /5.18 directory but looks like anything related to gettext is only in /5.16. Looking for guidance on how to fix this so that the needed files are found.


how to extract script output in new text file ?
5 direct replies — Read more / Contribute
by Chris202
on Oct 25, 2014 at 13:19
    Dear all I own nothing but faith in you all because I have tried to find the answer to my question on the internet for long but couldn't get (or understand) it... Here's my problem: I have a script that scans throught a text file and writes all line except those starting with an A.
    #!/usr/bin/perl use strict; use warnings; open (my $file, "<", "/file.txt") or die "cannot open < file.txt $!"; while (<$file>) { unless (/^A/) { print; } }
    That works, but I get the results of this script in the terminal. What I want is just to get these results to be saved in a new text file. Can somebody help me ? Please light my path amid the darkness with the wisdom that is yours Thanks a lot ! Chris
New Meditations
How to make a progress counter for parsing HTML with HTML::TreeBuilder
1 direct reply — Read more / Contribute
by ambrus
on Oct 30, 2014 at 12:33

    This is the true story of a trivial bug I made in a perl program yesterday.

    This program parses a 3 megabyte sized HTML file using the HTML::TreeBuilder module. The program takes less than 30 seconds to run, but that'ss still boring to wait and I'd like to see whether it hangs, so I decided to add a progress counter. Now, as I haven't written all of the program yet, much of the time is currently spent in just parsing the HTML file and building a tree representation in memory from it. Thus, I needed a progress counter in the HTML parsing itself (as well as one in the rest of the program).

    Before I added the progress counter, all of the HTML parsing happened in just one call of the HTML::TreeBuilder->parse_file method. If I kept that, if would be difficult to add a progress counter in it. Thus, I changed the code to instead read the HTML file in 64 kilobyte chunks, feed them each to the parser with the HTML::TreeBuilder->parse method, and print progress after each according to how much of the file is read.

    I thus wrote this.

    use HTML::TreeBuilder; my $filename = ...; my $tree = HTML::TreeBuilder->new; { open my $fileh, "<", $filename or die qq(error opening input h +tml file "$filename": $!); binmode $fileh; my $filesize = -s $fileh; while (read $fileh, my $buf, (1<<16)) { $tree->parse($buf); printf(STDERR "Parsing html, %2d%%;\r", int(100*tell($ +fileh)/($filesize+1))); } $tree->eof; print STDERR "Parsing html complete. \n"; }

    This worked fine. I got a comforting progress counter with percentages rolling quickly on the screen.

    Later, however, I wanted to work around a bug in the HTML, namely some missing open tags. This can be done mechanically, because this is a generated HTML file, but it was easier if I could modify the text of the HTML before parsing it to the tree, because otherwise the tree would have a wrong shape that would be difficult to fix.

    Thus, I chose to do some substitution on the text of the HTML before parsing it. This was easier by slurping the whole HTML file and doing substitutions on the whole thing. So I changed the code to slurp the file contents, substitute it, but then I still wanted to feed it to HTML::TreeBuilder in chunks to get a nice progress counter. No big deal, I wrote this.

    use HTML::TreeBuilder; my $filename = ...; my $tree = HTML::TreeBuilder->new; { printf STDERR "Reading html file.\n"; open my $fileh, "<", $filename or die qq(error opening input h +tml file "$filename": $!); binmode $fileh; local $/; my $filec = <$fileh>; eof($fileh) or die qq(error reading input html file); printf STDERR "Substing html file.\n"; $filec =~ ...; my $filesize = length $filec; printf STDERR "Substed html has length %d\n", $filesize; my $filetell = 0; while (my$buf = substr $filec, 0, (1<<16), "") { $filetell += length $filec; $tree->parse($buf); printf STDERR "Parsing html: %2d%%;\r", int(100*$filet +ell/($filesize+1)); } $tree->eof; print STDERR "Parsing html complete. \n"; }

    This didn't work. The progress counter started showing very high numbers, going up to tens of thousands of percents. I stopped the program because I was worried it got into an infinite loop repeatedly parsing the same part of the file over and over again, and will build an infinite tree.

    After a while, I found the problem. It turns out that the HTML was parsed correctly, only the progress was displayed wrong.

    Can you spot the bug? I'll reveal the solution under the fold.

RFC: QA Uploads
1 direct reply — Read more / Contribute
by mgv
on Oct 27, 2014 at 17:35

    Debian has a process called "QA uploads" if a package is orphaned1, any Debian Developer can upload a new version of the package without adopting it.

    When adopting a package/module, the adopter feels compelled to fix all bugs, add more tests, clean up everything, etc (otherwise they wouldn't be doing their job as maintainers). The amount of work discourages people from adopting modules.

    With QA Uploads, an interested user can fix that particularily annoying bug without the burden of having to maintain the module.

    Thus, I believe that adding QA uploads to PAUSE would increase the average quality of modules. I haven't thought about implementation details, but I think the PAUSE indexer could simply index any upload of an orphaned module.

    1 Debian / CPAN equivalence:
    O: / OrphanedADOPTME has f/m/c
    RFA: / Request for AdoptionHANDOFF has c
    RFH: / Request for HelpNEEDHELP has c
    QA Uploads are only possible for orphaned packages.
Reanimating regular issue: Indirect Object Notation
2 direct replies — Read more / Contribute
by McA
on Oct 27, 2014 at 06:22

    Hi all,

    as a regular reader of the Perlweekly newsletter I stumbled on this entry in Edition #170: Stop using indirect object notation.

    In the same moment I thought: Didn't I ask something related some time ago? Yes, I did. And I found it: Reference needed.

    So, I bring this to awareness once again.

    The reactions on twitter are interesting. IMHO the very first action that could be taken: Change all (changeable) documentation where new Class is used. Because most people don't care. They're copy&pasting the examples and synopsis of CPAN modules. And you can find this indirect notation on CPAN.


New Monk Discussion
Single code block split into multiple sequential code blocks.
3 direct replies — Read more / Contribute
by BrowserUk
on Oct 30, 2014 at 16:17

    Does any/everyone else see the first code block in Inline C memory leak split into 4 sequential code blocks?

    Is this a bug?

    This is the second or third time I've encountered this recently, though I can't remember which the other posts were.

    With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority".
    In the absence of evidence, opinion is indistinguishable from prejudice.
Google fonts
1 direct reply — Read more / Contribute
by Loops
on Oct 30, 2014 at 04:16

    Google has a large collection of free fonts that are hosted for use on web sites. You can use them in your own personal CSS for this site if that's your kind of thing. Here is example CSS that you could paste into your Display Settings in the "On-Site CSS Markup" field. I think it looks good with the Dark theme selected, but it should work with any.

    @import url(''); @import url(,40 +0italic,700); * { font-family: 'Merriweather', serif !important; } .titlebar { display:none; } /* Remove title bar from top of every +screen */ .monktitlebar { font-size: 80%; } /* Make top link list a little sm +aller */ textarea { width: 90%; height: 30em; } /* Don't post through a keyho +le */ tbody.nodelet td { font-size: 14px !important; } /* Reduce sidebar s +quint */ /* Put border around code areas, and select monospaced Google font */ tt.codetext { display: block; margin-right: 5px; padding: 4px 4px 4px 4px; font-size: 96%; border: 2px solid gray; -webkit-border-radius: 3px; -moz-border-radius: 3px; border-radius: 3px; font-family: 'PT Mono', monospace !important; }

    If you do decide to use different fonts, google makes it quite easy:

  • Find the font you like and click on its "Quick Use" button
  • Scroll down to step-3 for your selected font
  • Click on the "@import" tab (since Standard is shown by default)
  • Copy the shown "@import" line for your font
  • In Display Settings, replace the import from the CSS above to use yours instead
  • You'll also need to copy the font-family line from step-4 and replace it in the CSS too
  • Obligatory Screenshot and another Screenshot with Indie Flower font

    *The code-border CSS was based on a PM post that evades my search fu right now, sorry

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 rifling through the Monastery: (13)
As of 2014-10-31 18:47 GMT
Find Nodes?
    Voting Booth?

    For retirement, I am banking on:

    Results (223 votes), past polls