Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options

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
Tk::BrowseEntry set function -solved
2 direct replies — Read more / Contribute
by glenn
on Jul 25, 2014 at 11:40

    Hi monks. So because I love pain I want to know if anyone else has found such a solution to this bug lack of functionality. The BrowseEntry which provides a drop down has 3 functions: insert, delete, and get. I want a fourth 'set', rather than defining yet another global var as I already pass the obj to insert/delete I would love to be able to '->set(0)' to set the current value to index 0 of the list. Any suggestions or pointing in the correct direction would be appreciated. Thank you for your time.

Storing part of a regex in a variable
1 direct reply — Read more / Contribute
by jonneve
on Jul 25, 2014 at 11:37
    Hello all, I'm writing a rather complex script for converting C++ code to Pascal. A number of patterns or sub-pattern occur rather often, and therefore, I'm trying to put them into variables for later use. Here are my variables :
    $braces = qr/(?<braces>\{ ([^\{\}] | (?&braces))*? \} )/x; $brackets = qr/(?<brackets>\( ([^\(\)] | (?&brackets))*? \))/x; $identifier = qr/(?<identifier> \w+($brackets)?( \s*(\.|->)(?&identifi +er))?)/;
    The $brackets and $braces variables work as I expected, but the $identifier variable doesn't work right, for example :
    #This works $meth_impl =~ s/((?<identifier> \w+($brackets)?( \s*(\.|->)(?&identifi +er))?)) \s* \. \s* Trim\(\)/Trim($1)/xg; #This doesn't match anything: $meth_impl =~ s/($identifier) \s* \. \s* Trim\(\)/Trim($1)/xg;
    As you can see in the example above, I'm using the $brackets variable in both cases, and it works nicely. Could the problem be that my $identifier variable itself includes the $brackets variable? Do I need to eval it or something to force it to interpolate it correctly? Thanks in advance, Jonathan Neve
Understanding Inline::C to call vendor libraries
2 direct replies — Read more / Contribute
by murrayn
on Jul 25, 2014 at 02:31
    I have installed and successfully tested Inline::C with a simple "Hello World" and vowel counter (from the Inline::C Cookbook) so I'm reasonably happy that the installation is correct. I now want to invoke a vendor's C written API from Perl. The vendor's sample C code includes the line: #define SHLIBNAME dptcpiphi.dll My Perl code includes the following in order to access (I pray) the functions which I expect to be contained in dptcpiphi.dll:
    use Inline C => Config => AUTO_WRAP => ENABLE; use Inline C => Config => LIBS => '-L"C:\Program Files\Common Files\Pr +oduct\4.1\dptcpiphi.dll" -ldptcpip';
    The full Perl script is short:
    #!/usr/bin/perl -w use Inline C => Config => AUTO_WRAP => ENABLE; use Inline C => Config => LIBS => '-L"C:\Program Files\Common Files\Pr +oduct\4.1\dptcpiphi.dll" -ldptcpip'; use Inline C => DATA ; use strict; my $DPbuff = "statusbuffer"; my $status = MyGetCtrlStatus('0x14','localhost','1703',$DPbuff); print "$status\n"; __END__ __C__ int MyGetCtrlStatus(char ShiftCmd, char pHostName, char uPortNum, char + pCtrlStatus) { char JobInfo; int status = DPGetCtrlStatus(ShiftCmd, pHostName, uPortNum, pCtrlS +tatus); printf ("Running...\n"); return pHostName; }
    The gcc compile step appears to complete successfully but when it comes time to link the object libraries together it fails:
    Test_pl_5261.o:Test_pl_5261.c:(.text+0x27): undefined reference to `DP +GetCtrlStatus' collect2: ld returned 1 exit status dmake.exe: Error code 129, while making 'blib\arch\auto\Test_pl_5261\ +Test_pl_5261.dll'
    (I know the code isn't going to work at present but I can fix that as long as I can get Inline::C to link the vendor libraries into my Perl script.) Have I completely misinterpreted the purpose and capabilities of Include::C or simply made a mess of using the tool?
Running perl scripts in parallel
3 direct replies — Read more / Contribute
by perl_help26
on Jul 23, 2014 at 10:48
    Hello ! I have two perl scripts : and that are supposed to run forever in parallel. Is it possible to call these scripts from a third perl script? i.e. ---------------------------- system('perl -w; system('perl -w;
Firefox/Javascript/Perl CGI argument passing issue
4 direct replies — Read more / Contribute
by beckmanel
on Jul 22, 2014 at 10:40

    I'm using CGI::Application::Dispatch on the Perl backend

    Data is sent from Javascript:

    88 var _factories = [ 89 function() { return new XMLHttpRequest(); }, 90 function() { return new ActiveXObject("Msxml2.XMLHTTP"); } +, 91 function() { return new ActiveXObject("Microsoft.XMLHTTP") +; } 92 ]; 93 94 var _factory = null; 95 96 function newRequest() { 97 if (_factory != null) return _factory(); 98 99 for(var i = 0; i < _factories.length; i++) { 100 try { 101 var factory = _factories[i]; 102 var request = factory(); 103 if (request != null) { 104 _factory = factory; 105 return request; 106 } 107 } 108 catch(e) { 109 continue; 110 } 111 } 112 _factory = function() { 113 throw new Error("XMLHttpRequest not supported"); 114 } 115 _factory(); 116 } 1233 var http_request; 1234 http_request = newRequest(); 1252 var query = "ip=" + document.getElementById('ip').value; 1253'POST', "/", t +rue); 1254 http_request.send(query); 1255 return false;

    But when I do the same action from the same web page, but different browsers, I get parameters in a different form through Perl CGI (see below). My code has been working with the IE form, can I do anything to make the Firefox output form similar ?

    THANKS Much in advance.

    The below was generated in the target Perl procedure by:

    print STDERR "QUERY: ", Dumper($self->query), "\n";

    FIREFOX 15202 [Tue Jul 22 08:55:55 2014] [error] [client] QUERY: + $VAR1 = bless( {, referer: 15203 [Tue Jul 22 08:55:55 2014] [error] [client] + '.parameters' => [, referer: 15204 [Tue Jul 22 08:55:55 2014] [error] [client] + 'POSTDATA', referer: http://56.207.201. +210:8083/ 15205 [Tue Jul 22 08:55:55 2014] [error] [client] + ],, referer: 15206 [Tue Jul 22 08:55:55 2014] [error] [client] + '.charset' => 'ISO-8859-1',, referer: +0:8083/ 15207 [Tue Jul 22 08:55:55 2014] [error] [client] + 'POSTDATA' => [, referer: 15208 [Tue Jul 22 08:55:55 2014] [error] [client] + 'ip=', referer: http://56.207. +201.210:8083/ 15209 [Tue Jul 22 08:55:55 2014] [error] [client] + ],, referer: 15210 [Tue Jul 22 08:55:55 2014] [error] [client] + '.fieldnames' => {},, referer: 15211 [Tue Jul 22 08:55:55 2014] [error] [client] + 'escape' => 1, referer: 15212 [Tue Jul 22 08:55:55 2014] [error] [client] + }, 'CGI' );, referer: 15213 [Tue Jul 22 08:55:55 2014] [error] [client] , refe +rer: 15214 [Tue Jul 22 08:55:55 2014] [error] [client] [Tue J +ul 22 08:55:55 2014] Use of uninitialized value in pattern +match (m//) at /var/www/smartncm_test_ie11/lib/OpenNCMApp/EntryPoint. +pm line 896., referer: 15215 [Tue Jul 22 08:55:55 2014] [error] [client] [Tue J +ul 22 08:55:55 2014] Use of uninitialized value in pattern +match (m//) at /var/www/smartncm_test_ie11/lib/OpenNCMApp/EntryPoint. +pm line 897., referer: IE 15332 [Tue Jul 22 08:58:58 2014] [error] [client] QUERY: + $VAR1 = bless( {, referer: 15333 [Tue Jul 22 08:58:58 2014] [error] [client] + '.parameters' => [, referer: 15334 [Tue Jul 22 08:58:58 2014] [error] [client] + 'ip', referer: +83/# 15335 [Tue Jul 22 08:58:58 2014] [error] [client] + ],, referer: 15336 [Tue Jul 22 08:58:58 2014] [error] [client] + '.charset' => 'ISO-8859-1',, referer: +0:8083/# 15337 [Tue Jul 22 08:58:58 2014] [error] [client] + 'ip' => [, referer: 15338 [Tue Jul 22 08:58:58 2014] [error] [client] + '', referer: +083/# 15339 [Tue Jul 22 08:58:58 2014] [error] [client] + ],, referer: 15340 [Tue Jul 22 08:58:58 2014] [error] [client] + '.fieldnames' => {},, referer: +# 15341 [Tue Jul 22 08:58:58 2014] [error] [client] + 'escape' => 1, referer: 15342 [Tue Jul 22 08:58:58 2014] [error] [client] + }, 'CGI' );, referer: 15343 [Tue Jul 22 08:58:58 2014] [error] [client] , refe +rer:
print package's symble table
4 direct replies — Read more / Contribute
by vinoth.ree
on Jul 22, 2014 at 04:06

    Hi Monks,

    I was doing somthing wrong, pls help me on this.

    I was trying to print the symble table of a package of mine.below is my package code

    package Vinoth; use strict; use warnings; use Data::Dumper; our $VERSION=1.0; sub printSimbleTable{ my $package = shift; print "I am in printSimbleTable of : $package\n"; print Dumper \%$packge::; #Not working print Dumper \%Vinoth::; # Works #print Dumper \%{$packge}::; #Not working # foreach my $varName (sort keys %$package::) # { # print "$varName\n"; # local *typeglob = %{$package}::{$varName}; # print "$$varName\n" if ($typeglob); # } } 1;

    I tried to use this package in a perl script and calling a function in this module to print the package's symble table. Below is the script file

    use strict; use warnings; use Vinoth; &Vinoth::printSimbleTable( 'Vinoth' );

    As you can see this line print Dumper \%$packge::; #Not working the $package hash my module name 'Vinoth', but its not printing the symble table with the Dumper, when I replace it with the my module name explicity, it works. how to use $package variable here and make it work ?


    Packages and Symbol Tables

    A package's namespace is a symbol table. The name of your package is stored in a hash named after your package with two colons appended to it. If you name a package BushWhack, its symbol table name is %BushWhack::. Packages are represented as %main:: or %:: in the symbol table by default. Since we're dealing with a hash, each key must have a value. Because keys are identifiers, values are the corresponding typeglob values; globs are pretty efficient because they do the symbol table lookups at compile-time. In other words, *BushWhack represents the value of %BushWhack::--see the following:

    local *low_flyer = *BushWhack::variable; # compile time local *low_flyer = *BushWhack::{"variable"}; # run time

    You can look up all the keys and variables of a package with this example. You may use undef() on these to clear their memory, and they will be reported as undefined. You shouldn't undefine anything here unless you don't plan to load these packages again. Because the memory has already been filled, it saves time when you load them if you leave them defined:1

    foreach $symbol_name (sort keys %BushWhack::) { local *local_sym = $BushWhack::{$symbol_name}; print "\$$symbol_name is defined\n" if($local_sym); print "\@$symbol_name is defined\n" if(@local_sym); print "\%$symbol_name is defined\n" if(%sym); }

    All is well
Bizarre Dancer encoding behavior
3 direct replies — Read more / Contribute
by xyzzy
on Jul 20, 2014 at 21:25

    Short version: When using return to send a response, Dancer converts a Unicode string into ISO8859-1. When setting the content directly via the Dancer::Response->new() method, the response contains the correct string.

    Long version: I have an extremely minimal Dancer app. At some point, I was going to expand it to do a lot more, but as of right now the only thing it does is return the currently-playing track of an MPD server running on the same machine. A static page with an HTML5 internet radio player sends a request and updates a "Now Playing:" span at regular intervals. I needed something quick and dirty without mucking about with the two MPD modules on CPAN, so I used a system call. For those unfamiliar with MPD, it is a music player with a server-client architecture. There are a plethora of clients available for all different platforms, but the most basic is a CLI client called mpc. Called with no arguments, it returns the server status:

    xyzzy@asscat:~$ mpc
    ДДТ - Чёрно-белые танцы
    [playing] #27/31 1:21/6:03 (21%)
    volume: n/a repeat: off random: off single: off consume: off

    Here's the first version:

    get '/np' => sub { return `mpd | head -n1`; }

    Simple enough. But instead of the Unicode, my span looks like this:

    Now playing: ””Т - Ч‘€но-бел‹е ‚а톋

    I spent an hour trying to enable utf8, checking the HTTP headers, the meta tags on the page, even using Encode, but nothing worked. Then I rewrote my handler like so:

    get '/np' => sub { Dancer::Response->new( status => 200, content => `mpd | head -n1`, ); }


    Now playing: ДДТ - Чёрно-белые танцы

    Most of me only cares that it works now. But part of me is still baffled why one way works and the other way doesn't. What is it about return that mangles the sting encoding? It has to be something inherent in Dancer, because if I do

    xyzzy@asscat:~$ perl -e'sub a {return `mpc|head -n1`}print a'
    ДДТ - Герой

    it works perfectly fine. Does anyone here know enough about Dancer's internals or is clever enough to figure this out?

    $,=qq.\n.;print q.\/\/____\/.,q./\ \ / / \\.,q.    /_/__.,q..
    Happy, sober, smart: pick two.
Win32 GUI onDrag?
2 direct replies — Read more / Contribute
by AndreaN
on Jul 20, 2014 at 11:26


    I'm currently creating an application in which I use the onDropFiles event of Win32::GUI.

    I wanted the icon of the button to change when the user is dragging the file on it. I looked in the documentation but I didn't find any event like a "onDraggedFile" or anything similar. Has anybody found this problem? Did I miss something or is it just impossible to change icon in this way using Win32::Gui?


New Cool Uses for Perl
Install missing modules with Module::Extract::Install's cpanm-missing/cpanm-missing-deep
No replies — Read more | Post response
by frozenwithjoy
on Jul 24, 2014 at 12:07

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

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

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

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

    Dear Monks,

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

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

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

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


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

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 examining the Monastery: (6)
As of 2014-07-26 16:11 GMT
Find Nodes?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:

    Results (178 votes), past polls