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

The Monastery Gates

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

Donations gladly accepted

  • (Sep 10, 2018 at 22:53 UTC) Welcome new users!
If you're new here please read PerlMonks FAQ
and Create a new user.

New Questions
DBD::pg considers input and output ISO8859
1 direct reply — Read more / Contribute
by apz
on Sep 25, 2018 at 14:22

    Dear monks,

    Many moons ago I wrote a Perl script for data entry into PostgreSQL database over a web GUI. The system ran on Ubuntu server 14.04 and it never had any issues with encoding. What was posted from a web form had encoding that would make it readable from PostgreSQL's shell client.

    The system however needs to be upgraded to 18.04 and here's where the issue arose. Now all the output I get from DBD:Pg is in ISO8859. The database itself is in UTF8, the server and client both report UTF8 as encoding. I can run queries interactively or from one shot shell commands and receive the data in correct encoding. But not if used from DBI.

    I installed a fresh 18.04 installation to debug the issue and the problem persists. Here's an example of the issue:

    First creation of a demo table:

    demo=> create table demo (content varchar); CREATE TABLE demo=> \d demo Table "public.demo" Column | Type | Collation | Nullable | Default ---------+-------------------+-----------+----------+--------- content | character varying | | | demo=> insert into demo (content) values (''); INSERT 0 1 demo=> insert into demo (content) values ('aaaaaa'); INSERT 0 1 demo=> select * from demo; content --------- aaaaaa (2 rows)

    So far so good. If the last select query is redirected to a text file, examining it with a hex editor reveals it's UTF8, file-command agrees.

    Next we try the same with DBI:

    use DBI qw(:utils); $DBcon=DBI->connect("DBI:Pg:dbname=demo", "demo", "demo-pass"); $DBhandle=$DBcon->prepare("SELECT * FROM demo"); $DBhandle->execute(); if ($DBI::rows > 0) { print $_->{'content'}." - ".data_string_desc($_->{'content'})."\n" w +hile $_ = $DBhandle->fetchrow_hashref(); } $DBcon->disconnect();
    Instead of replicating what came out in PostgreSQL's interactive shell, we get:
    ������ - UTF8 on, non-ASCII, + 6 characters 12 bytes aaaaaa - UTF8 on, ASCII, 6 characters 6 bytes

    If redirected to a text file, hex editor shows that this isn't UTF8 and again file-command agrees. If I insert any data into the database with DBI, it will be entered as double-UTF8'd. The system has PostgreSQL 10, Perl 5.26.1, DBI 1.640 and DBD::pg 3.7.0.

    So dear monks, what's going on?

Net::SFTP::Foreign error
2 direct replies — Read more / Contribute
by roperl
on Sep 25, 2018 at 14:15
    When using Net::SSH2 as backend to SFTP:Foreign. I get a HASH ref where I'm expecting to get the error condition. How do I get the error string?
    use Net::SSH2; use Net::SFTP::Foreign; my $ssh2 = Net::SSH2->new( timeout => '30000' ); $ssh2->connect( $host, $port ) $ssh2->auth( username => $user, password => $pass ) my $sftp = Net::SFTP::Foreign->new( ssh2 => $ssh2, backend => 'Net_SSH +2', timeout => '30' ); $sftp->put( "$file", "$destfile", best_effort => 1, atomic => $atomic +) or ( warn( "Put failed: $sftp->error\n" ) && exit 1 );
    When the put fails I get the warn error as shown below Error: Put failed: Net::SFTP::Foreign=HASH(0x123b3c0)->error
can one create a "session" of Perl & Mysql?
4 direct replies — Read more / Contribute
by Anonymous Monk
on Sep 25, 2018 at 10:38
    Hi Monks!
    I have made a script with Perl and Mysql, executing queries. The script works fine, the thing I would like to change -if possible- is to not need to write the credentials all the time, but only when I first execute it, and then somehow they remain stored until I logout or something.
    My script looks as follows:
    use strict; use warnings; use Term::ReadKey; use DBI; use List::Util qw( min max ); use Data::Types qw/:all/; use DateTime; use DateTime::Format::Strptime; use Date::Calc qw(:all); my $dates_file = $ARGV[0]; my $dsn = "DBI:mysql:DiabetesDB"; print "Please give your username:"; my $username = <STDIN>; chomp $username; ReadMode(0); print "Password for user \"$username:\""; ReadMode('noecho'); my $password = ReadLine(0); ReadMode 'normal'; chomp $password; # connect to MySQL database my %attr = ( PrintError=>0, # turn off error reporting via war +n() RaiseError=>1 # turn on error reporting via die( +) ); my $dbh = DBI->connect($dsn,$username,$password, \%attr); print "\nUser \"".$username."\" is connected to the \"DiabetesDB\" dat +abase.\n"; my ($patient_id_date, $specific_date, $wanted_date, $type_of_search, $ +max_window, $sql_query)=''; open DATES, $dates_file; while(<DATES>) { chomp; if($_=~/^(.*?)\t(.*?)\t(\d+)\t(.*)/) { $patient_id_date=$1; $specific_date=$2; $max_window=$3; $type_of_search=$4; my %p; @p{qw(year month day)} = split /\//, $specific_date; my $dt = DateTime->new(%p); my $wanted_date = $dt->clone->add(months => $max_window)->strf +time('%Y/%m/%d'); #this is the date I am interested in, +X months if($type_of_search eq 'past') { $sql_query = "SELECT * FROM MEASUREMENTS WHERE MEASUREMENT +S.patient_id='".$patient_id_date. "' AND MEASUREMENTS.measure_date<'".$wanted_d +ate."' ORDER BY MEASUREMENTS.measure_date DESC LIMIT 1"; } elsif($type_of_search eq 'future') { $sql_query = "SELECT * FROM MEASUREMENTS WHERE MEASUREMENT +S.patient_id='".$patient_id_date. "' AND MEASUREMENTS.measure_date>'".$wanted_d +ate."' ORDER BY MEASUREMENTS.measure_date ASC LIMIT 1"; } elsif($type_of_search eq 'both') { $sql_query = "(SELECT * FROM MEASUREMENTS WHERE MEASUREMEN +TS.patient_id='".$patient_id_date. "' AND MEASUREMENTS.measure_date<'".$wanted_d +ate."' ORDER BY MEASUREMENTS.measure_date DESC LIMIT 1)". " UNION (SELECT * FROM MEASUREMENTS WHERE ME +ASUREMENTS.patient_id='".$patient_id_date. "' AND MEASUREMENTS.measure_date>'".$wanted_d +ate."' ORDER BY MEASUREMENTS.measure_date ASC LIMIT 1)"; } my $sth = $dbh->prepare($sql_query); $sth->execute(); $sth->dump_results( ); $sth->finish(); print "\n"; } } close DATES;

    So, as you can see, the user is asked to provide his/her credentials when calling the script. I was wondering if there is a way so that the user does it once, but if they re-run the script 2 mins later, they can still be "logged in" on the Mysql server. Is that possible, and, if yes, how does one go about it?

    Thanks!
3 member list ouput
2 direct replies — Read more / Contribute
by catfish1116
on Sep 25, 2018 at 10:20
    I am trying to create a 3 member list from <STDIN>. All I get is the number 3. I even copied what was in the book, (Learning Perl 7th ed), and to no avail. I am running perl 5.22 Below is my code. Any help greatly appreciated !
    say "Please enter 3 string variables, :" . "(Please crtl-D after ent +ering strings)\n "; @lines = <STDIN>; say 'Here ' . @lines; chomp(@lines); @backwards = reverse(@lines); say "Here are the values in reverse order:" . @backwards;

    And here is the output:

    Please enter 3 string variables, :(Please crtl-D after entering string +s) aaa bbb ccc Here 3 Here are the values in reverse order:3

    Discipulus added code tags

Perl length if condition not working
3 direct replies — Read more / Contribute
by kanewilliam7777
on Sep 25, 2018 at 06:09
    my $param_value='123456789'; if(length($param_value)!=10) { print 'Fail'; } else { print 'Success'; }

    Needed & correct result is "Fail". but it's return "Success".

    Please let me know how to check the string length

goto HACK
5 direct replies — Read more / Contribute
by Anonymous Monk
on Sep 25, 2018 at 03:27
    I need to build a hash with unixtime keys and eliminate duplicates without losing entries. Since the exact time is not too important I came up with this hack that increments keys until they're unique. But this is so wrong! I need some help figuring out the right way with an array:
    #!/usr/bin/perl use strict; use warnings; use Data::Dumper; my @times = qw(1000 1000 1000 1010 1010 1010); my $hash = {}; my $seen = {}; for my $time (@times) { if ($seen->{$time}) { HACK: $time++; if ($seen->{$time}) { goto HACK } else { $seen->{$time}++ } } else { $seen->{$time}++ } $hash->{$time}->{one} = 1; $hash->{$time}->{two} = 2; } print Dumper $hash;
    Thank you for your time.
How to check the request is (GET OR POST) in CGI
3 direct replies — Read more / Contribute
by kanewilliam7777
on Sep 24, 2018 at 08:34

    I have used CGI method

    Please let me know how to check request the value (GET OR POST) in CGI

[OT] Folding Perl code with Emacs 25
4 direct replies — Read more / Contribute
by loris
on Sep 24, 2018 at 04:45

    Hi,

    To get folding in Emacs 25 for Perl programs I have cargo-cult-copied the outline-based set-up https://github.com/villadora/emacs-config/blob/master/modes.el.

    In particular I have:

    ;; CPerl mode hook (setq cperl-mode-hook 'my-cperl-customizations) (defun my-cperl-customizations () "cperl-mode customizations that must be done after cperl-mode load +s" (outline-minor-mode) (abbrev-mode) (defun cperl-outline-level () (looking-at outline-regexp) (let ((match (match-string 1))) (cond ((eq match "=head1" ) 1) ((eq match "package") 2) ((eq match "=head2" ) 3) ((eq match "=item" ) 4) ((eq match "sub" ) 5) (t 7) ))) (setq cperl-outline-regexp my-cperl-outline-regexp) (setq outline-regexp cperl-outline-regexp) (setq outline-level 'cperl-outline-level) )

    My expectation was that if I have

    =head2 STUFF =over =item foo Do foo =cut sub foo { return 'foo'; }

    I should be able to fold to

    =head2 STUFF...

    but instead I just can only fold to, say

    =head2 STUFF... =item foo Do foo =cut sub foo { return 'foo'; }

    i.e. the hierarchy, which I thought gets defined by 'outline-level' doesn't seem to work.

    I do have

    (add-hook 'outline-minor-mode-hook 'outshine-hook-function)

    to get tab-cycling, but maybe this is screwing things up.

    Any thoughts or other approaches?

    Thanks,

    loris

    Note: This is something I originally posted, somewhat spuriously, to the Orgmode mailing list several weeks ago. Not that surprisingly, I got no reply.

What does "bad handshake" mean when connecting to mysql with DBD::mysql?
1 direct reply — Read more / Contribute
by Cody Fendant
on Sep 22, 2018 at 20:05
    • My sqld is up and running
    • I can connect to it just fine with a mysql client and PHPMyAdmin and select, update etc
    • However when I try to connect to it with DBD::mysql I get "bad handshake" in DBI->errstr()

    What kind of things can I check on? How can I debug this?

CPAN modules to read xlsx file in v.5.6
2 direct replies — Read more / Contribute
by Arunkumar_141
on Sep 22, 2018 at 13:19
    Hi, Need CAPN module details to read xlsx files in v.5.6
file handing
5 direct replies — Read more / Contribute
by bigup401
on Sep 22, 2018 at 09:17

    i want to open file and insert it into dir with new filename

    my $NFILE = "09911"; #NEW FILE NAME my $FILE = '02190.JPG'; #FILE TO OPEN my $openfile = open(DATA, ">$FILE"); #OPEN FILE my $newfile = rename($openfile, $NFILE); #RENAME FILE FROM 02190.JPG T +O 09911.JPG my $writefile = open(DATA,">>", "img/$newfile"); #INSERT THE FILE IN I +MG DIR WITH NEW NAME 09911.JPG close DATA;
Perl MongoDB Results and Version (batch_size??)
2 direct replies — Read more / Contribute
by maikelnight
on Sep 21, 2018 at 15:57
    Hi Monks, i have some code that works pretty fine with MongoDB v0.705.0.0 :
    use Data::Dumper; use DateTime::Format::Strptime; use POSIX qw(strftime); use MongoDB; use Data::Structure::Util qw( unbless ); use strict; use warnings; my $mongoclient = MongoDB::MongoClient->new( host => '127.0.0.1', port => 27017 ); my $db = $mongoclient->get_database('database'); my $collect = $db->get_collection('collection')->aggregate([ {'$group' => { '_id' => {_path => '$path' , _ip => '$IP', _time => '$TIME'}, '_count' => { '$sum' => 1}, '_docs' => { '$push' => '$_id' } } }, { '$match' => { '_count' => { '$gt' => 1} }} ]); my $mongo_aggregate = unbless $collect; my @out = (@$mongo_aggregate); print Dumper @out;
    I receive a few thousand results what is expected and checked in database....so far so good...On another system with MongoDB v1.2.2 i receive only 101 results:
    use Data::Dumper; use DateTime::Format::Strptime; use POSIX qw(strftime); use MongoDB; use Data::Structure::Util qw( unbless ); use strict; use warnings; my $mongoclient = MongoDB::MongoClient->new( host => '127.0.0.1', port => 27017 ); my $db = $mongoclient->get_database('database'); my $collect = $db->get_collection('collection')->aggregate([ {'$group' => { '_id' => {_path => '$path' , _ip => '$IP', _time => '$TIME'}, '_count' => { '$sum' => 1}, '_docs' => { '$push' => '$_id' } } }, { '$match' => { '_count' => { '$gt' => 1} }} ]); my $mongo_aggregate = unbless $collect->{'_docs'}; my @out = (@$mongo_aggregate); print Dumper @out;
    If i dump my $collect i found a hint that says: '_batch_size' => 101 I believe thats the point where im stucking. I dont know how to solve the issue nor i can fix that with documentation (as im advanced beginner). Can someone please shed some light on me, please. Thanks, regards,
New Cool Uses for Perl
Finding Differential Cryptanalysis Inputs with PDL
No replies — Read more | Post response
by mxb
on Sep 21, 2018 at 10:35

    In addition to Perl and PDL, one of my favourite topics is cryptography, specifically cryptanalysis.

    One 'common' cryptanalytical attack, for which modern ciphers are designed against is differential cryptanalysis. Some older ciphers are vulnerable to this attack and various tutorials exist to teach differential cryptanalysis. One of these is by Jon King against the FEAL cipher and is located here.

    One aspect of the differential cryptanalysis attack is to enumerate all potential differentials against the non-linear round function. The below code performs this analysis against the FEAL-4 cipher's round sub-function 'G'. It successfully identifies the two fixed input differentials.

    Enjoy!

    #!/usr/bin/env perl use 5.020; use warnings; use autodie; use PDL; use PDL::NiceSlice; # This code attempts to find all differential characteristics in the # FEAL-4 cipher round subfunction 'G'. # # Reference: http://theamazingking.com/crypto-feal.php # # # 'G' function is addition of a, b and x, then bitwise rotate left # by 2 bits # a, b, x and the final value are all 8 bits. # For our purposes, x can be ignored, as it's constant 0 or 1 # # a # | # x -> [+] <- b # | # [<<<] # | # OUT # # Perform addition my $G = sequence( byte, 256 ) + sequence( byte, 256 )->transpose; # Bitwise rotation $G = ( $G << 2 ) | ( $G >> 6 ); # At this point, $G contains all possible inputs for a and b, and # the associated output value # # Now we wish to find all differentials throughout this function # # To do this, we need to find differentials between each possible # inputs to 'a', and 'b' and observe the differential in the result # # There are two known differentials for this function. A differential # value of 0 and 0x80 (128) for 'a' will always return a constant # differential output (0 and 2) respectively. # Calculate the differential table my $diffs = $G ^ $G ( (0) ); # Find the minimum and maximum value for each differential my ( $min, $max ) = minmaxover($diffs); # Print index of differentials where minimum and maximum value are # equal. As the index is also in the input value, this returns the # actual differential: print "Contant differentials for input differentials of: ", which( $min == $max ), "\n";
Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (3)
As of 2018-09-26 03:11 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Eventually, "covfefe" will come to mean:













    Results (205 votes). Check out past polls.

    Notices?
    • (Sep 10, 2018 at 22:53 UTC) Welcome new users!