Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask

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
Feature Idea: qr//e
2 direct replies — Read more / Contribute
by haukex
on Jan 18, 2017 at 08:47

    Dear Monks,

    As I was thinking about this node about dynamically building regexes, I had the idle thought that it might be nice if qr// supported qr//e, analogous to s///e it would eval the inside of the construct before parsing it as a regex. Now this is really just a very minor itch, and I don't yet have any idea of how much sense it makes or how difficult it might be to implement, but I still thought I'd bounce it off of you.

    # The "normal" solution my $regex = join '|', map {quotemeta} qw/. | %/; $regex = qr/$regex/; # The "hacked" solution my $regex2 = qr{@{[ join '|', map {quotemeta} qw/. | %/ ]}}; # Wouldn't this be a bit nicer? my $regex3 = qr{ join '|', map {quotemeta} qw/. | %/ }e;

    Thoughts? Maybe the "normal" and/or "hacked" solutions above are good enough, and the effort required to implement qr//e isn't worth it? Other potential problems I haven't noticed yet?

    -- Hauke D

ActiveState new vs old?
3 direct replies — Read more / Contribute
by enrgyxprt
on Jan 18, 2017 at 07:59
    Its been a while since I installed ActiveState perl, perl -V shows I have V5 something... So I updated all using PPM.. Now I am thinking about updating to the newest activestate community version... Any downsides ?
binding listbox with perl tkx
3 direct replies — Read more / Contribute
by Anonymous Monk
on Jan 17, 2017 at 12:15
    hello, i am using perl 5.22 with tkx on Windows 10. with tk, i succeed to bind buttonrelease-1 to a new_tk__listbox. but with tkx i do not succeed to bind the button to a new_tkx_Scrolled("listbox". that is to say, when i clic, Nothing happens. if somebody can look at this problem, that would be very fine for me, thanks by qadvance. here is my little test program.
    use Tkx; use Tkx::Scrolled; use strict; my $lbox; my $mw= Tkx::widget->new("."); $mw->g_wm_minsize(200,200); $mw->g_wm_resizable(1,1); $mw->g_wm_focus(); display_main(); Tkx::MainLoop; sub clic { #$box_value=$sous_lbox2->get($sous_lbox2->curselection()); my $val=$lbox->curselection(); print "val=$val\n"; return if ($val eq ""); my $value=$lbox->get($lbox->curselection()); print "$value\n"; } sub display_main { # $lbox=$mw->new_tk__listbox(-height=>5,-selectmode => "single"); $lbox=$mw->new_tkx_Scrolled("listbox",-scrollbars=>"se",-height=>5,- +selectmode => "single"); $lbox->g_pack( -anchor=>'n', -padx=>3, -pady=>3, -expand=>1, -fill=>'both'); foreach my $key ("aa","bb","cc") { $lbox->insert('end', "$key- "); } $lbox->g_bind('<ButtonRelease-1>' , sub { clic() }); }
Win32::Process::Info and threads
3 direct replies — Read more / Contribute
by LineStown
on Jan 17, 2017 at 07:30

    Hello all

    Could you help with perl?

    I have next code (it is a mini version of trouble):

    use strict; use threads; use Win32::Process::Info; sub test { print "1"; } threads->create(\&test)->join();

    Result: 1Free to wrong pool 2c3fd30 not 6a8eb0 during global destruction.

    It happens after ->join()

    It works without ​use Win32::Process::Info;

    Win32::Process::Info need for getting command line of process.

    Win32::Process::Info qw{NT} doesn't give all information.


[OT] Can I create a new license based on the Artistic License 2.0?
4 direct replies — Read more / Contribute
by YellowApple
on Jan 16, 2017 at 16:26

    Scenario: I want to create a new license (say, the "Dramatic License"). It's identical to the Artistic License 2.0 in every way except that Section 4b is omitted (with the intended result of always requiring the Modified Version to be made available to at least myself under the Original License, or to the general public under the Original License or some other copyleft free software license), and Section 4c is renumbered to Section 4b to fill in the gaping void left behind.

    However, the Artistic License 2.0 contains this bit of legalese right off the bat:

    "Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed."

    It seems the GNU General Public License and various derivatives include this exact wording as well, but there are indeed licenses derived from the GNU GPL (including the Affero General Public License). The GNU GPL FAQ also seems to authorize modified versions of the GPL despite that wording, provided that the derivative license removes any reference to GNU or the FSF (in order to avoid the appearance of the new license being endorsed by the FSF) and that the new license must be approved by the FSF in order to use the Preamble at all.

    Thus, this all leaves me with some questions:

    • Would it be legally permissible to create a new license under a different name that is identical to the Artistic License 2.0 (aside from the removed section as described above)? Or am I totally out of luck here?
    • Would it be legally permissible to use Sections 4a and 4c from the Artistic License 2.0 as the basis for a similar clause or clauses in an entirely different license (not identical to the Artistic License 2.0)? Or am I again totally out of luck here?

    Basically, the Artistic License 2.0 seems to be absolutely perfect for my needs (at least when I need copyleft at all) with the sole exception of Section 4b (in the rare situation where I actually want copyleft, I really don't care whether or not some fork is "compatible" with my version or is named differently; I care whether or not the fork is free software or at the very least available to me under the Original License). Being able to use the same exact licensing terms as the AL2.0 sans that specific section would be absolutely ideal. Barring that, being able to write a new license from scratch while incorporating AL2.0 Sections 4a and 4c (whether paraphrased or verbatim) would be acceptable.

Handling Exceptions on Net::SSH::Expect
1 direct reply — Read more / Contribute
by pablor
on Jan 16, 2017 at 14:56

    I am using Net::SSH::Expect to connect to a list of access points.

    In some cases the connection dies and my script gets interrupted. I want the script to skip the AP but continue with the following ones, but the script dies

    my $sshap = Net::SSH::Expect->new ( host => $apip, user => 'Cisco', ssh_option => '-o StrictHostKeyChecking=no', raw_pty => 1, timeout => 5 ); if($sshap->run_ssh()){ $sshap->waitfor ('Password:', 7) or warn "SSH problem: 'Password' +not found after 7 second"; $sshap->send ('Cisco'); $sshap->waitfor ("$ap\>", 3) or warn "SSH problem: $ap\> not found + after 3 second"; $sshap->send ('en'); $sshap->waitfor ('Password:', 3) or warn "SSH problem: 'EN Passwor +d' not found after 3 second"; $sshap->send ('Cisco'); $sshap->waitfor ("$ap\#", 3) or warn "SSH problem: $ap\# not found + after 3 second"; $sshap->send ('show ip interface brief'); while (defined ($line = $sshap->read_line()) ) { print "$line\n" } $sshap->send('exit'); $sshap->close(); } else { print "$apname Could not open SSH\n"; }

    I found that I can handle that by using eval{}

    Is that the best approach?

    it seems that is running much slower when I use eval.

Some help with my project:
2 direct replies — Read more / Contribute
by 0uts1de
on Jan 16, 2017 at 14:01

    Hi monks,i am quite new in perl programming (only 2 weeks learning)and i have a question about my script, the idea is that the script prints some things about a choosen filesystem and gives the avalible space, the used space, the type, etc.

    All sounds good, but when I run my script it returns a error ("Illegal division by zero at analizer (16-1-17).pl line 35, <STDIN> line 1.") and I dont know how to fix it or what is working bad, the code is this: (NOTE: I am spanish so i write the comments in my lenguaje, sorry if u dont understand it but i dont think is necesary a traduction)

    #!usr/bin/perl #solo funciona para unix/linux/solaris(solaris ni idea) #si da el error "Undefined subroutine &main::SYS_statfs called at +Filesys/ at line XXX", editar # (en el perl lib tree) y copiar la linea "SYS_statfs {196;}" fuer +a del "if (defined &__hp9000s800)" (alrededor de la linea 356) use strict ; use warnings ; use Filesys::DiskSpace ; use POSIX ; #sistema de archivos/particion a comprobar espacio #sacar fecha ; my $TIME = strftime("%d/%m/%Y %H:%M:%S", localtime(time) ) ; print "+----------+---+----------+\n" ; print "+Script made up by 0uts1de+\n" ; print "+----------+---+----------+\n" ; print "Today is $TIME \n" ; print "Write the filesystem/partiton you want to monitor, for exam +ple /home or /usr \n" ; my $monit = <STDIN> ; chomp $monit ; print "##warning level is by default about a 20 % of free space, i +f u want to change this##\n" ; print "##change the variable warn in the script with a editor like + vim or gedit ##\n" ; ########## warn string ############ my $warn = 10 ; ################################### #consegir caracteristicas de la particion/filesystem (raw) my ($fs_type, $fs_desc, $used, $avail, $fused, $favail) = df $moni +t ; my $monit_percentual = ( $avail / $avail+$used ) * 100 ; my $final_used = $used / 1000 ; my $final_avail = $avail / 1000 ; print "$monit is a $fs_type filesystem who has $final_used space u +sed (in MB) and $final_avail of avalible space (in MB too) \n" ; #comparacion con el porcentaje de $monit_percentual if ($monit_percentual < $warn) { print "Less of the $warn % of the space of the filesystem +$monit is avalible for use, consider uninstall unused software \n" ; } elsif ($monit_percentual eq $warn) { print "Be carefull, exactly the $warn % of the space of $m +onit is usable, consider uninstall unused software \n" ; } else { print "There is a $monit_percentual % of avarible space of + the disk \n" ; }

    In the imput I have the error and the rest, here is:

    +----------+---+----------+ +Script made up by 0uts1de+ +----------+---+----------+ Today is 16/01/2017 16:31:04 Write the filesystem/partiton you want to monitor, for example /home o +r /usr / ##warning level is by default about a 20 % of free space, if u want to + change this## ##change the variable warn in the script with a editor like vim or ged +it ## Illegal division by zero at analizador de filesystem (16-1-17).pl line + 35, <STDIN> line 1.

    Thanks in advance!

DBIx or Catalyst problem: Lost connection to MySQL server during query
2 direct replies — Read more / Contribute
by Largo
on Jan 16, 2017 at 09:04

    Hi there!

    I'm working on a project using the Catalyst framework. The db access is done by DBIx::Class. All works fine until the queries get too complicated and take too long to run.

    Therefore I wrote a test script to find out if there is a fix amount of time after which the db crashes and the answer is yes. If a query takes longer than 50 seconds then we get the error msg:

    DBI Exception: DBD::mysql::st execute failed: Lost connection to MySQL server during query

    For testing I use the query "SELECT SLEEP(n);" which does nothing but to sleep for n seconds and then returns.
    Here is my test code:

    use encs; my $sto = encs->model("DB::Exset")->new({})->result_source->schema +->storage; printf("start\n"); foreach my $i (49,50,51,52,53,49) { print("wait $i seconds:\n"); my $t1 = time; my $t2 = undef; eval { $sto->dbh_do( sub { my ($storage, $dbh, @cols) = @_; $t2 = time; my $sth = $dbh->prepare("Select sleep($i)") or die $db +h->errstr; $sth->execute or die $sth->errstr; my $data = $sth->fetchrow_hashref; } ); }; if ( $@ ) { printf("ERROR: %s (%d, %d)\n", $@, time - $t1, time - $t2); + } else { printf("Ok: (%d, %d)\n", time - $t1, time - $t2); } } printf("end\n"); exit;
    A typical run:
    start wait 49 seconds: Ok: (92, 49) wait 50 seconds: Ok: (86, 50) wait 51 seconds: ERROR: {UNKNOWN}: DBI Exception: DBD::mysql::st execute failed: Lost c +onnection to MySQL server during query [for Statement "Select sleep(5 +1)"] at ./script/ line 32 (86, 51) wait 52 seconds: ERROR: {UNKNOWN}: DBI Exception: DBD::mysql::st execute failed: Lost c +onnection to MySQL server during query [for Statement "Select sleep(5 +2)"] at ./script/ line 32 (51, 51) wait 53 seconds: ERROR: {UNKNOWN}: DBI Exception: DBD::mysql::st execute failed: Lost c +onnection to MySQL server during query [for Statement "Select sleep(5 +3)"] at ./script/ line 32 (51, 51) wait 49 seconds: Ok: (49, 49) end

    "encs" is my Catalyst class. 50 seconds are running through and 51 seconds are failing. Interestingly the query breaks everey time after 51 seconds, but it's not the mysql server that ends the connection. There ist no error message at the mysql server. If I setup a DBI connection on my own, without Catalyst, then it runs as long as it takes. Therefore I think it's an Catalyst/DBIx issue.

    My Catalyst YAML config for db: Model::DB: schema_class: encs::Schema::DB connect_info: dsn: dbi:mysql:encs01_test:encsdb user: uu password: xxxxx options: mysql_connect_timeout: 600 net_read_timeout: 600 net_write_timeout: 600

    Does anybody have an idea what is the problem? How I could configure Catalyst to avoid this timeout?

    Thx, Lars

Undiagnosable Problem
4 direct replies — Read more / Contribute
by dhannotte
on Jan 14, 2017 at 10:37

    Last week my Perl interpreter suddenly started issuing a bizarre cascade of warnings every time I tried to run my '' script. These warnings claimed that every variable exported from my '' library had already been defined. It then aborted the interpretation of '' entirely at the first invocation of one of these "multiply defined" functions.

    My '' script begins with the following 4 "use" statements:

    use Plx; # Programming Language Extensions use PlxHml; # HTML Macro Languages use PlxLang; # Language Services use strict 'vars';

    '' exports 23 functions and begins:

    package PLX; use attributes; use diagnostics; use strict 'vars'; use warnings; use Date::Calc; use Math::BigFloat; use Carp; $SIG{__WARN__} = \&carp; $SIG{__DIE__} = \&confess;

    '' exports 1 function and begins:

    package PLXHML; use PLX; use Carp; $SIG{__WARN__} = \&carp; $SIG{__DIE__} = \&confess;

    '' exports 3 functions and begins:

    package PLXLANG; use PLX; use Carp; $SIG{__WARN__} = \&carp; $SIG{__DIE__} = \&confess;

    Each of the exported functions is unique. This structure has worked for years without error.

    My Perl site lib contains the following files:

    -------------------------------------------------------------------- c:\Perl64\site\lib()dir Volume in drive C is C-DRIVE Volume Serial Number is E812-30A4 Directory of c:\Perl64\site\lib 01/13/2017 07:34 AM <DIR> . 01/13/2017 07:34 AM <DIR> .. 09/02/2010 02:49 PM <DIR> auto 09/02/2010 02:49 PM <DIR> Image 01/13/2017 07:34 AM 161,042 01/09/2017 04:33 PM 10,113 01/11/2017 10:28 AM 15,241 01/11/2017 10:27 AM 61,873 01/27/2010 01:36 PM 31 12/26/2010 01:13 AM 106 6 File(s) 248,406 bytes 4 Dir(s) 651,360,083,968 bytes free --------------------------------------------------------------------

    The command I use to interpret, and the first few and last few of the spurious errors, are:

    -------------------------------------------------------------------- c:\!dh\dh\web\PRC\1() Subroutine TRUE redefined at C:/Perl64/site/lib/ line 280 (#1) (W redefine) You redefined a subroutine. To suppress this warning +, say { no warnings 'redefine'; eval "sub name { ... }"; } Subroutine TRUE redefined at C:/Perl64/site/lib/ line 280. at C:/Perl64/site/lib/ line 13 (#1) Subroutine TRUE redefined at C:/Perl64/site/lib/ line 280. at C:/Perl64/site/lib/ line 13 at C:/Perl64/site/lib/ line 13 Subroutine FALSE redefined at C:/Perl64/site/lib/ line 281 (#1) Subroutine FALSE redefined at C:/Perl64/site/lib/ line 281. . . . Subroutine x_yyyy_mm_dd_hh_mm_ss redefined at (#2) line 3990 (#1) Subroutine x_yyyy_mm_dd_hh_mm_ss redefined at (#2) line 3990. at C:/Perl64/site/lib/ line 13 Undefined subroutine &main::x_hh_mm_ss called at C:\!dh\dh\web\PRC\1\s line 347. at C:\!dh\dh\web\PRC\1\ line 347 --------------------------------------------------------------------

    Line 280 of is:

      sub TRUE      {1}

    Line 13 of is:

      use PLX;

    I suspect that there's a simple explanation for all this, but even after a decade of using Perl, I am unable to imagine what it is. Do these spurious errors ring a bell with anyone? The version of Perl I use is described by the following output from the 'perl -v' and 'perl -V' commands:

    I suppose I could reinstall ActivePerl, but they're no longer friendly to freeloaders like me and this might not succeed. I could try Strawberry Perl, but I don't have LINUX and managing it might be difficult. Before I descend into these circles of hell, I really hope that one of the wise elders here can offer me even a glimmer -- even just a smudgeon -- of insight. Thanks in advance.

Cannot get Perl to match a specific string in my textfile
3 direct replies — Read more / Contribute
by skasch
on Jan 12, 2017 at 09:50
    Dear list,

    I am a beginner with Perl and seek wisdom of the monks

    What i want is to read a file, run a regex on its lines and when matching substitute some strings according to a map.

    Mostly that does work but on a specific line, i cannot get my regex to match and I like to understand why

    This is an excerpt of one of the files that should be processed

    "" = <*I0>; }; SubscribedFolders = ( "" ); FoldersOrder = ( personal, "user_A_domain_D_com_BCA-513DD600-1B-6967B200", "7D03-5682B480-975-5FFE8000", "7D03-5682B480-977-5FFE8000" ); FreeBusyExclusions = { "" = <*I0>; "" = <*I1>;

    And this is my Code

    #!/usr/bin/perl use strict; use warnings; use autodie; my %replacements = ( '' => 'uname', '' => 'user', ); open( my $readFile, '<', "sampleFile" ); while ( <$readFile> ) { # if contains :Calendar and is suffixed with / # or :Contacts with same suffix or Users prefixed # with / or is an email-address followed by " = if ( m/:Calendar(?=\/)/, m/:Contacts(?=\/)/, m/(?<=\"\/)Users/, m/.+@.+\"\s=/) { # then replace every occurrence as in list foreach my $key ( sort keys %replacements ) { s/\b$key\b/$replacements{$key}/g; } } print $_; }

    And this is the result

    "uname:Calendar/personal" = <*I0>; }; SubscribedFolders = ( "" ); FoldersOrder = ( personal, "user_A_domain_D_com_BCA-513DD600-1B-6967B200", "7D03-5682B480-975-5FFE8000", "7D03-5682B480-977-5FFE8000" ); FreeBusyExclusions = { "uname:Calendar/personal" = <*I0>; "user:Calendar/BCA-513DD600-1B-6967B200" = <*I1>;

    I do not understand why my regex does not match the string under "Subscribed Folders" any help is greatly appreciated

    cheers, Sascha
EOF problem with Dancer streaming proxy
2 direct replies — Read more / Contribute
by dsheroh
on Jan 12, 2017 at 08:59
    I have a system which needs to act as a proxy to another of our servers, mainly for legacy support reasons. With the help of Dancer as a proxy, I've managed to get it mostly working with the following code:
    return send_file( \'ignored', streaming => 1, callbacks => { override => sub { eval { my $client_connection = shift; my $ua = LWP::UserAgent->new; my $client; my $status = $ua->get($real_url, ':content_cb' => sub { my ($data, $resp) = @_; unless ($client) { my $headers_in = $resp->headers; my %headers_out = ( 'Content-Disposition' => sprintf('inline; filename="%s"', $file->{fileName}), ); for (qw( Content-Type Content-Length Keep-Alive Last-Mod +ified )) { $headers_out{$_} = $headers_in->header($_) if $headers_in->header($_); } $client = $client_connection->([$resp->code, [%headers_o +ut]]); } $client->write($data); }); if ($status->is_error) { my $headers_in = $status->headers; my %headers_out; for (qw( Content-Type Content-Length Keep-Alive Last-Modif +ied )) { $headers_out{$_} = $headers_in->header($_) if $headers_in->header($_); } my $client = $client_connection->([$status->code, [%header +s_out]]); $client->write($status->error_as_HTML); } 1; } or warn "Proxy failure: $@"; return; }, }, );
    I say "mostly working" because, while the files are streamed successfully and browsers will accept them without complaint, wget and curl are less forgiving. Both of these command-line programs issue errors after the file is (successfully) received:
    $ curl -sS -o rcvd https://foo/bar.pdf curl: (18) transfer closed with outstanding read data remaining $ wget https://foo/bar.pdf <...> 2017-01-12 14:48:58 (6.10 MB/s) - Read error at byte 3316868 (Success. +).Retrying. <proceeds to loop endlessly>
    The byte at which wget reports the read error is always the last byte of the file (i.e., equal to the file size), leading me to suspect that an EOF marker isn't being handled properly. Possibly also relevant is that, while the proxying code copies the Content-Length header from the original source, the original source does not provide that header, so Content-Length is not actually set.

    Using curl/wget to download the file directly from the original source works perfectly with no error messages issued.

    Does anyone have any insights as to what the cause of the problem might be?

    Edit: On further investigation, the problem does not appear to be with Dancer itself. Testing with Dancer's internal mini-server (using bin/ does not exhibit this problem. It only shows up in the production environment, which has Apache <-> Starman <-> Dancer. So now to work out whether the issue is with one of the other components individually or with the interactions between them.

New Meditations
[RFC] Building Regex Alternations Dynamically
2 direct replies — Read more / Contribute
by haukex
on Jan 18, 2017 at 07:57

    Dear Monks, this is a suggestion for a tutorial, any comments or suggestions are welcome. Update 1: Fixed up explanation of metacharacters a bit.

    I thought it might be useful to explain the technique of building regular expressions dynamically from a set of strings, since I've done this myself many times. Let's say you have a list of strings, like ("abc", "def", "ghi"), and you want to build a regex that matches any of them, like /abc|def|ghi/. This also works well with s/search/replacement/ if you have a hash where the keys are the search strings and the values are the replacements, as I'll show below.

    First, the basic code, which I explain below - note the numbering on the lines of code.

    my @values = qw/ a ab. d ef def g|h /; my $regex = join '|', # 4. map {quotemeta} # 3. sort { length $b <=> length $a } # 2. @values; # 1. $regex = qr/$regex/; # 5. print "$regex\n"; # 6.
    1. We begin with the list of strings stored in the array @values. This could be any list, such as a literal qw/.../, or return values from functions, including keys or values.
    2. We sort the list so that the longer strings appear first. This is necessary because if our regular expression was /foo|foobar/, then applied to the string "foobarfoofoobar", it would only match "foo" three times, and never "foobar". But if the regex is /foobar|foo/, then it would correctly match "foobar", "foo", and again "foobar".
    3. Next, we apply the quotemeta function to each string, which escapes any metacharacters that might have special meaning in a regex, such as . (dot, matches anything) or | (alternation operator). In our example, we want the string "g|h" to be matched literally, and not to mean "match g or h". Unescaped metacharacters can also break the syntax of the regex, like stray opening parentheses or similar. Note that quotemeta is the same as using \Q...\E in a regex. As discussed here, you should only drop \Q...\E or quotemeta in the case that you explicitly want metacharacters in your input strings to be special, they come from a trusted source, and you are certain that your strings don't contain any characters that would break your regular expression or expose security holes!
    4. Then, we join the strings into one long string using the regex alternation operator |. If you want to use this string without the qr// of step 5, note this potential pitfall: For example, if your input is qw/a b c/, then at this point your string will look like $regex="a|b|c". Then, saying /^$regex$/ will be interpolated to /^a|b|c$/, which means "match a only at the beginning of the string, or b anywhere in the string, or c only at the end of the string", which is probably not what you meant, you probably meant /^(a|b|c)$/, that is /^($regex)$/!
    5. Finally, we compile the regular expression using qr//. This is not strictly necessary, you could just interpolate the string you've just created into a regex, but I prefer to turn them into regex objects explicitly. It also has the advantages that you can apply modifiers such as /i to the regex in a (IMO) more natural way, and that qr// implicitly adds a non-capturing group (?:...) around the regex, which takes care of the problem described in step 4 above.
    6. When we print the regular expression, we see that it has become this:
      You can now use this precompiled regular expression anywhere, as explained in Compiling and saving regular expressions and perlop, such as if ($input=~$regex) { ... } or while ($input=~/$regex/g) { ... }.

    Search and Replace Using a Hash

    my %map = ( a=>1, ab=>23, cd=>45 ); # 1. my $regex = join '|', # 2. map {quotemeta} sort { length $b <=> length $a or $a cmp $b } # 3. keys %map; $regex = qr/$regex/; print "$regex\n"; # 4. # Now, use the regex my @strings = qw/ abcd aacd abaab /; # 5. for (@strings) { my $before = $_; s/($regex)/$map{$1}/g; # 6. print "$before -> $_\n"; # 7. }
    1. This is the hash in which the keys are the search strings, and the values are the replacements. As above, this can come from any source.
    2. This code to build the regex is mostly the same as the above, with differences noted here.
    3. Instead of only sorting by length, this sort first sorts by length, and sorts values with the same length with a stringwise sort. While not strictly necessary, I would recommend this because hashes are unordered by default, meaning that your regex would be in a different order across different runs of the program. Sorting the hash keys like this causes the regex to be in the same order in every run of the program.
    4. We print the regex for debugging, and see that it looks like this: (?^:ab|cd|a)
    5. These are the test strings we will apply the regular expression against.
    6. This is the search and replace operation that matches the keys of the hash, and as a replacement value gets the corresponding value from the hash. Note that the /g modifier is not strictly required, and you can adapt this regex any way you like - so for example, to only make one replacement anchored at the beginning of the string, you can say s/^($regex)/$map{$1}/;.
    7. The output of the code is:
      abcd -> 2345 aacd -> 1145 abaab -> 23123

    Hope this helps,
    -- Hauke D

New Cool Uses for Perl
Reading from an HC-SR04 ultrasonic distance sensor on the Raspberry Pi
1 direct reply — Read more / Contribute
by stevieb
on Jan 13, 2017 at 17:38

    I've completed another Raspberry Pi related distribution, RPi::HCSR04. This one allows you to use Perl to read data from the HC-SR04 ultrasonic distance sensor.

    It's trivial to use, however, because it uses wiringPi internally, your scripts require root privileges.

    use warnings; use strict; use feature 'say'; use RPi::HCSR04; my $trig_pin = 23; my $echo_pin = 24; my $sensor = RPi::HCSR04->new($trig_pin, $echo_pin); # each call is a separate poll say $sensor->raw; say $sensor->cm . " cm"; say $sensor->inch . " \"";


    634 10.915135593358 cm 4.29729747772217 "

    There's still a bit more work I have to do (catch out-of-range measurements etc), but it works pretty well and is surprisingly accurate.

    Note that per the documentation, the HC-SR04 requires 5v in, and also returns 5v from the ECHO pin back to the Pi's GPIO (which only handles 3.3v), so a voltage regulator or voltage divider is required to limit the voltage to a healthy 3.29v. I opted for the divider while writing the software. Here's a diagram depicting how I achieved that.

    Next up, a SN74HC595 shift register, as I need it to continue to work on the other various projects I have going on. I've almost completed the dist for the BMP180 barometric/altimeter sensor, as well as the MCP300x series analog-to-digital converters.

Log In?

What's my password?
Create A New User
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (4)
As of 2017-01-19 02:19 GMT
Find Nodes?
    Voting Booth?
    Do you watch meteor showers?

    Results (167 votes). Check out past polls.