Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

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 question: Dynamically disable radiobutton choices
1 direct reply — Read more / Contribute
by chafelix
on Jul 18, 2018 at 08:32

    I am creating a dialog for comparing two files. For matching purposes, the user needs to tell the program how to handle fields (for instance excel columns). Thus, the interface needs to a) specify that column i in file A corresponds to column j in file B and b) whether these matching columns are First name, last name or neither. This is important because an exact match will be performed for last name, but a first digit match will be performed on first name, e.g. 'Tim' vs. 'Timothy' should be a match. So I am adding a radiobutton for each column with the choices 'First, last and no name'. The trick is that once there is only one 'First name' and 'last name' column, so once the user has specified that this is a first name, this option should not be available to other columns.

    Apart from this, which I am not sure how to do there seem to be 2 more issues with the code below: First, the Radiobutton part seems to give a strange message Second, the Browseentry appears to be filled in the box instead of the expanding list

    use Tk; use Tk::BrowseEntry; my $top=MainWindow->new(); $top->title("Match Specifications"); my @names=('Last Name','First Name','Not a name'); my $value=2; #no name is default my $indicator=0;#start looping over names, indicator=0=>Last, 1=>first +, 2=>no name %main::A={1=>['Tim','Doe','other_info1'], 2=>['Mick','Lu','other_info_2']}; %main::B={1=>['Timothy','Doe','other_info1','moreinfo1'], 2=>['Michail','Lu','other_info_2','moreinfo2']}; $main::headers[0]=['F','L','O']; $main::headers[1]=['M','J','P','JJ']; my $fr=$top->Frame(-relief=>'sunken')->pack(-anchor=>'nw',-fill=>'both +'); my $counter0=0; my @selector; my $col=0;my $colshow=0; my @keys00=sort keys %main::A;my @keys0=(); push @keys0,$keys00[0]; push @keys0,$keys00[1]; my @keys200=sort keys %main::B; my @keys20=(); push @keys20,$keys200[0]; push @keys20,$keys200[1]; my $row1=0; foreach my $el(@{$main::headers[0]}){ my $row=0; $selector[$col]=$fr->Scrolled('BrowseEntry',-label=>$el,-variable=>\$ +main::matchhash{$col}, -browsecmd=>[\&show,$el,\@headers2,\@keys200]); my $h2cnt=0 ; my $h2cntall=0; ##### this is the part that must be repopulated dynamically foreach my $el2(@{$main::headers[1]}){ $selector[$col]->insert("end", $el2); $h2cnt++; $h2cntall++;}#foreach el2 $selector[$col]->grid(-row=>$row,-column=>$colshow); #### end of part to repopulate dynamically $row++; #row nonzero $fr->Label(-text=>$main::A{$keys0[0]}->[$col])->grid(-row=>$row,-colum +n=>$colshow);$row++; $fr->Label(-text=>$main::A{$keys0[1]}->[$col])->grid(-row=>$row,-colum +n=>$colshow);$row++; foreach my $name(@names){ $fr->RadioButton( -text=>$name,-variable=>\$indicator,-value=>$value) +->grid(-row=>$row, -column=>$colshow); $row++;} $colshow++; $row1=$row; $col++;}#foreach el ####### $fr->Button(-text=>'Run',-bg=> 'firebrick1' ,-command=>sub{ } ) +->grid(-row=>$row1,-column=>1); &MainLoop(); sub show{my $el=shift; my $rheaders=shift; my $rkeys=shift; }
Syntax Perl Version support $c = () = $a =~ /\./g
6 direct replies — Read more / Contribute
by h2
on Jul 17, 2018 at 14:02

    Hi Perl Monks, I have what is hopefully a simple question, but one I have been unable to search for due to the odd syntax of the below.

    The program I'm working on has a core requirement to work on older systems, and has a cutoff of Perl 5.008 (selected because Redhat mid 2000s release was quite late to support 5.010) or newer, though that could change in the future to either a touch earlier version, or a touch later version (but certainly never newer as max oldest than 5.010). As an aside, so far Perl 5.x has far exceeded my wildest expectations in this regard, the program is in fact working on everything! No matter how weird or arcane.

    my $a='3.4.4'; my $c = () = $a =~ /\./g; print "$c\n"

    However, my question is this: when did Perl begin supporting this type of structure?

    $c = () = $a =~ /\./g

    I've come across this several times, and I'm allured by it, it calls to me, but I have to be careful using structures that could trigger warnings or failures in old systems.

    I'd actually like to significantly expand my use of this type of structure, so besides this specific example, can anyone point me to the right search terms that describe it, that's multiple assignments of some value generated on the right side of the items? And also I believe various items that could be in the second position, (), though I'm not positive about that. And has this support been consistent since version 5.xxx? Are there various types of this assignment that have been introduced earlier or later?

    I have the big Larry Walls Perl book, but I don't know what this is called to begin learning more about it, and what variants will be safe to use.

Using Perl XS in 5.26 fails with error loadable library and perl binaries are mismatched
3 direct replies — Read more / Contribute
by jobinjoseph121
on Jul 17, 2018 at 08:35
    Hi,

    We have build Perl 5.26.1 from source and used the same Perl to create a perlmodule.c file from an XS file perlmodule.xs. But when we try to execute this C code, we get the following error.
    ../perlmodule.c: loadable library and perl binaries are mismatched (got handshake key 0xe280080, needed 0xde00080)

    Previously we were using Perl 5.16 and there were no issues. Could you please let us know whether we need to rewrite the XS module for Perl 5.26. Currently we are using the same XS module which is used in Perl 5.16. I am not sure if that is creating the issue here.

    We are generating the .c files with following command.
    perl ExtUtils/xsubpp -typemap typemap -typemap ExtUtils/typemap perlmodule.xs > perlmodule.cpp

    Following is the configuration details.

    Summary of my perl5 (revision 5 version 26 subversion 1) configuration +: Platform: osname=linux osvers=2.6.16.21-0.8-default archname=x86_64-linux-thread-multi uname='linux 2.6.16.21-0.8-default #1 mon jul 3 18:25:39 utc 2006 +x86_64 x86_64 x86_64 gnulinux ' config_args='-d -s -e -U uselargefiles -U use64bitint -U usemorebi +ts -D usemultiplicity -D usethreads -D prefix=/opt/perl/a -D installu +srbinperl=no -D useshrplib -D ccflags= -D libperl=libperl.so -D man1d +ir= -D perladmin=none -D pager=/usr/bin/less -D otherlibdirs=/opt/pe +rl/a/lib/site_perl' hint=recommended useposix=true d_sigaction=define useithreads=define usemultiplicity=define use64bitint=define use64bitall=define uselongdouble=undef usemymalloc=n default_inc_excludes_dot=define bincompat5005=undef Compiler: cc='cc' ccflags ='-D_REENTRANT -D_GNU_SOURCE -fno-strict-aliasing -pipe -f +stack-protector -I/usr/local/include -D_FORTIFY_SOURCE=2' optimize='-O2' cppflags='-D_REENTRANT -D_GNU_SOURCE -fno-strict-aliasing -pipe -f +stack-protector -I/usr/local/include' ccversion='' gccversion='4.1.0 (SUSE Linux)' gccosandvers='' intsize=4 longsize=8 ptrsize=8 doublesize=8 byteorder=12345678 doublekind=3 d_longlong=define longlongsize=8 d_longdbl=define longdblsize=16 longdblkind=3 ivtype='long' ivsize=8 nvtype='double' nvsize=8 Off_t='off_t' lseeksize=8 alignbytes=8 prototype=define Linker and Libraries: ld='cc' ldflags =' -fstack-protector -L/usr/local/lib' libpth=/usr/local/lib /usr/lib64/gcc/x86_64-suse-linux/4.1.0/../.. +/../../x86_64-suse-linux/lib /usr/lib /lib/../lib64 /usr/lib/../lib64 + /lib /lib64 /usr/lib64 /usr/local/lib64 libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdb +m_compat perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc libc=libc-2.4.so so=so useshrplib=true libperl=libperl.so gnulibc_version='2.4' Dynamic Linking: dlsrc=dl_dlopen.xs dlext=so d_dlsymun=undef ccdlflags='-Wl,-E -Wl,-rpath,/opt/perl/a/lib/5.26.1/x86_64-linux-t +hread-multi/CORE' cccdlflags='-fPIC' lddlflags='-shared -O2 -L/usr/local/lib -fstack-protector' Characteristics of this binary (from libperl): Compile-time options: HAS_TIMES MULTIPLICITY PERLIO_LAYERS PERL_COPY_ON_WRITE PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP PERL_OP_PARENT PERL_PRESERVE_IVUV USE_64_BIT_ALL USE_64_BIT_INT USE_ITHREADS USE_LOCALE USE_LOCALE_COLLATE USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LOCALE_TIME USE_PERLIO USE_PERL_ATOF USE_REENTRANT_API Built under linux

    Thanks and Regards,
    Jobin Joseph
IF condition with a range
7 direct replies — Read more / Contribute
by Anonymous Monk
on Jul 16, 2018 at 10:12
    Hi Monks,
    I want to write the following into and IF clause: "If the number is exactly equal, or equal+1 or equal-1".
    I guess I could write it like this:
    if($x==$y or $x==$y-1 or $x==$y+1)

    Is there a more compact way to write this?
    Thanks!
Print inside SIGNALS
4 direct replies — Read more / Contribute
by pedrete
on Jul 16, 2018 at 09:46
    Hi PerlMonks...

    Is there any safe way of print to STDOUT inside a signal?

    something like this

    alarm 10; $SIG{ALRM} = \&Finish; sub Finish { print "Timeout reached"; }

    does not work in Linux Debian.

    Thanks!

Is this a valid approach to finding if a path through a set of points has completed?
3 direct replies — Read more / Contribute
by atcroft
on Jul 16, 2018 at 03:26

    (I considered submitting this as a meditation, but due to my lack of knowledge on the topic, I thought better of posting there.)

    Recently I was thinking about a problem. Specifically, I was considering the idea from the point of view of "ants" (for lack of a better term) following all of the possible paths, and trying to think through how to determine if a path has been completed. As a starting thought experiment, I considered 6 points, with ants moving from each point to each remaining point. I thought of 5 different cases that could occur (points labeled '1'..'6', paths written ordered least to greatest):

    1. Incomplete connection - existing connections are 1-2 and 2-3.
    2. Incomplete connection - existing connections are 1-2, 2-3, 4-5, 5-6, and 1-6
    3. Incomplete connection - existing connections are 1-2, 2-3, 4-5, 5-6, and 1-6, extra connection 4-6
    4. Complete connection - existing connections are 1-2, 2-3, 3-4, 4-5, 5-6, and 1-6
    5. Complete connection - existing connections are 1-2, 2-3, 3-4, 4-5, 5-6, and 1-6, extra connections 3-5, 3-6, and 4-6

    The cases map out (roughly) as follows:

    (I realized as I was writing this that being able to find that a path might not be as useful as I thought, but that does not take *that much* away from this question.)

    I'm not aware of (or at least remember) dealing with graphs in the CS classes I took (years ago), so there may be a nice theory or approach I am not aware of. What I came up with was to create a matrix containing the number of connections between between points. (By writing all of the connections in least-greatest ordering, only half the matrix had to be used, as illustrated by the following. Unfilled entries are noted as '-', otherwise the count of connections is filled in in row-column order.)

    What I noticed was that in the cases (1-3) where a connection did not exist, there was at least one row in which the sum of entries on the row was zero, but in cases where a full path existed all rows had a non-zero sum. Is this approach too simplistic-minded (or did I just stumble upon something I should have known)?

    Sample code:

    Thank you for your attention and insights. (And my apologies if I have wasted your time.)

    Update: 2018-07-16

    Thank you for your feedback. To answer OM and tobyink, yes, apparently what I am looking for is a Hamiltonian path through the set. (I didn't know the proper term(s) to use to search, among other things.) To answer bliako, yes, I know ants would have started from each point, but for simplicity I showed only completed paths of equal length. To apply this to the original problem, I can see two ways: a) follow the idea of an actual ant, and track each ant's actual position, or b) knowing the edges and their lengths, I would probably look to move down the list of all edges (tracking the sum total) and update the matrix form (above, or other method) to check if a complete path exists.

How can I turn an op address into the right kind of B::OP?
2 direct replies — Read more / Contribute
by rockyb
on Jul 15, 2018 at 16:55

    O Omnificent Omnipotent Ones -

    In a running Perl program if I have an Op address (either by B::Concise, Devel::Callsite or via mysterious other ways) is there a simple way to cast that into the right kind of B::OP, short of walking an Opcode tree?

-scrollbars is unknown option in windowCreate
4 direct replies — Read more / Contribute
by Oberbee
on Jul 15, 2018 at 11:07

    Great Omniscient Masters,

    I am attempting to create a table of items with a uniform height inside an ROText widget. When attempting to use windowCreate to insert a scrollable ROText description I get this error:

    unknown option "-scrollbars" at ...

    Here is the code in question:

    $row0p0 = $top->Label(-text => $cat1, -height =>7, -width => 15, -relief => 'sunken')->grid( $row0p1 = $top->Label(-text => $lb12,-height =>7, -width => 15, -relief => 'sunken'), $row0p2 = $top->ROText(-height =>8, -width => 22, -wrap => 'word', -sc +rollbars => 'oe'), $row0p3 = $top->Button(-text => "Photo"), $row0p4 = $top->Button(-text => "Link")); $row0p2->insert('end', " [long description] "); $top->windowCreate('end', -window => $row0p0); $top->windowCreate('end', -window => $row0p1); $top->windowCreate('end', -window => $row0p2); $top->windowCreate('end', -window => $row0p3); $top->windowCreate('end', -window => $row0p4);

    How can I make this ROText widget scrollable?

Regex for outside of brackets
6 direct replies — Read more / Contribute
by theravadamonk
on Jul 13, 2018 at 06:49

    Hi Monks

    Is there a way to catch texts outside of brackets? I am looking for a regex..

    this is my string

    THIS IS OUTSIDE (THIS IS INSIDE)

    What I expect is

    THIS IS OUTSIDE

    below regex can catch what is inside.

    \((.*?)\)
    How can I catch things except what is inside?

    below matches everything except "(" and ")"

    [^()]

    Your INPUTS?

Add Quotes to entries in a file
7 direct replies — Read more / Contribute
by niseus
on Jul 12, 2018 at 08:56
    Hi, im having a File with semicolon(;) seperated entries

    For Example

    ABC;123;;;;;HELLO;

    DEF;345;;BANANA;12DEF;44,55;4*12;;;;;;;;3;

    and what i now need is a way to add quote around everything exept the first entry per Line

    ABC;"123";"";"";"";"";"HELLO";

    DEF;"345";"";"BANANA";"12DEF";"44,55";"4*12";"";"";"";"";"";"";"";"3";

    Each line can have a different amount of entries.

    So basicly i have to look into the file in a random folder add the quotes around everything.

    After that i have to copy the modified file into a new folder.

    How could a achive this?

What is a reliable way to get the package of the code creating a Moose object?
2 direct replies — Read more / Contribute
by nysus
on Jul 12, 2018 at 00:10

    I want a Moose object to behave differently depending upon which package has created the object. For example, if the "Teacher" package create the "Child" object, I want the "Child" object to behave different than if the "Parent" object created the "Child" object.

    To accomplish this, I have something like the following code:

    1 #! /usr/bin/env perl 2 use strict; 3 use warnings; 4 5 package Child; 6 use Moose; 7 8 has 'context' => (is => 'rw'); 9 10 sub BUILD { 11 my $s = shift; 12 my ($pkg) = caller 4; 13 $s->context('Teacher') if $pkg eq 'Teacher'; 14 $s->context('Parent') if $pkg eq 'Parent'; 15 } 16 17 package Teacher; 18 my $tom = Child->new(); 19 print $tom->context . "\n"; 20 21 package Parent; 22 my $kit = Child->new(); 23 print $kit->context . "\n";

    This works, but it is dependent upon line 12 guessing that the original caller being 4 (5?) levels deep.If Moose internals change at all, the code will break. So I'm wondering if there might be a more reliable and documented way of accomplishing this. Or perhaps it's best to pass in the "context" as an argument to the constructor (though this seems like a less cool approach)? It also seems like this approach could have a proper name in computer science but I'm not aware of. If you can educate me, I'd appreciate it. Thanks!

    $PM = "Perl Monk's";
    $MCF = "Most Clueless Friar Abbot Bishop Pontiff Deacon Curate Priest";
    $nysus = $PM . ' ' . $MCF;
    Click here if you love Perl Monks

New Meditations
use Memoize;
2 direct replies — Read more / Contribute
by Anonymous Monk
on Jul 16, 2018 at 15:18
    I was porting a script to a module and noticed it kept getting slower. The script could initialize its expensive data structure once at the top and be done with it, but in order to encapsulate, the module was calling the function several times. I remembered the core module Memoize and added one line to the top of the program and now it runs fast again, 4x faster than without Memoize!
    
    use Memoize; memoize('some_sub');
    
    
    Only 1.5 seconds to start a program that was taking 6 seconds!
New Cool Uses for Perl
Send email with OAuth 2 through Gmail SMTP or API
No replies — Read more | Post response
by Veltro
on Jul 12, 2018 at 17:09

    Hello,

    I wrote a program containing two methods regards sending a simple email with Gmail with OAuth 2 authorization. Method 1 uses Gmail SMTP server and Method 2 uses Gmail API. I wrote all my notes inside of the program so please read those first, especially the security consideration section. There are a few steps required to get this working which have been described in the main program.

    I hope the programs will be usefull to you,

    With best regards, Veltro

    The first method needs a mechanism to authenticate, I have written the following module for that, that you must place in .\Authen\SASL\Perl\XOAUTH2.pm

    #!/usr/bin/perl # Copyright (c) 2018 Veltro. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # This package is provided "as is" and without any express or implied # warranties, including, without limitation, the implied warranties of # merchantability and fitness for a particular purpose # # Description: # Part of SASL authentication mechanism for OAuth 2.0 (RFC 6749) # This package contains the method to create the initial client # response according to the format specified in: # https://developers.google.com/gmail/imap/xoauth2-protocol package Authen::SASL::Perl::XOAUTH2 ; use strict ; use warnings ; our $VERSION = "0.01c" ; our @ISA = qw( Authen::SASL::Perl ) ; my %secflags = ( ) ; sub _order { 1 } sub _secflags { shift ; scalar grep { $secflags{$_} } @_ ; } sub mechanism { # SMTP->auth may call mechanism again with arg $mechanisms # but that means something is not right if ( defined $_[1] ) { die "XOAUTH2 not supported by host\n" } ; return 'XOAUTH2' ; } ; my @tokens = qw( user auth access_token ) ; sub client_start { # Create authorization string: # "user=" {User} "^Aauth=Bearer " {Access Token} "^A^A" my $self = shift ; $self->{ error } = undef ; $self->{ need_step } = 0 ; return 'user=' . $self->_call( $tokens[0] ) . "\001auth=" . $self->_call( $tokens[1] ) . " " . $self->_call( $tokens[2] ) . "\001\001" ; } 1 ;

    The program uses a template that needs to be put here .\templates\test.txt.tt

    Hi [% first_name %], This is a test message from your Perl program! Japh,

    The program requires two modules that needs to put in the same folder as your script: .\ClientSecret.pm and .\ClientCredentials.pm

    #!/usr/bin/perl # Copyright (c) 2018 Veltro. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # This package is provided "as is" and without any express or implied # warranties, including, without limitation, the implied warranties of # merchantability and fitness for a particular purpose # # Description: # Helper package to read the client secrets json file package ClientSecret ; use strict ; use warnings ; use JSON qw( decode_json ) ; sub new { my $class = shift ; my $fp = shift ; # Full Path to json secret file or undef # If undef, then each parameter needs # to be specified manually in params my ( %params ) = @_ ; # undef or overwrite all default # json attributes my $this = { clientID => 'installed/client_id', projectId => 'installed/project_id', authUri => 'installed/auth_uri', tokenUri => 'installed/token_uri', authProviderX509CertUrl => 'installed/auth_provider_x509_cert_ +url', clientSecret => 'installed/client_secret', redirectUris => 'installed/redirect_uris' } ; if ( %params ) { @{$this}{keys %params} = @params{keys %params} ; } bless $this, $class ; if ( defined $fp ) { if ( $this->readJson( $fp ) ) { return $this ; } } return 0 ; } sub readJson { my $this = shift ; my $fp = shift ; my $fh ; if ( !open $fh, "<", $fp ) { warn "Could not open $fp\n" ; return 0 ; } my $json = '' ; while( <$fh> ) { chomp ; $json = $json . $_ ; } close $fh ; my $decoded_json = decode_json( $json ) ; foreach ( keys %{$this} ) { my @nodes = split /\//, $this->{ $_ } ; $this->{ $_ } = $decoded_json->{ shift @nodes } ; while ( @nodes ) { $this->{ $_ } = $this->{ $_ }->{ shift @nodes } ; } } return ( defined $this->{ clientID } && defined $this->{ clientSec +ret } ) ; } 1 ;
    #!/usr/bin/perl # Copyright (c) 2018 Veltro. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # This package is provided "as is" and without any express or implied # warranties, including, without limitation, the implied warranties of # merchantability and fitness for a particular purpose # # Description: # Helper package to store the client credentials # in a JSON file (both refresh token and access token) # and to be able to determine if the refresh token is # available and the access token is still valid. package ClientCredentials ; use strict ; use warnings ; use JSON qw( decode_json encode_json -convert_blessed_universally ) ; sub new { my $class = shift ; my $fp = shift ; # Full Path to JSON credentials file # (or the file that needs to be created) my $this = { _filePath => $fp, accessToken => undef, expiresIn => undef, time => undef, refreshToken => undef, tokenType => undef } ; bless $this, $class ; if ( defined $fp ) { if ( -f $fp ) { $this->readJson( $fp ) ; if ( $this->expired ) { $this->{ accessToken } = undef ; $this->{ expiresIn } = undef ; $this->{ time } = undef ; $this->{ tokenType } = undef ; } } } return $this ; } sub refreshTokenNeeded { my $this = shift ; return 1 unless ( defined $this->{ refreshToken } ) ; return 0 ; } sub expired { my $this = shift ; return 1 unless ( defined $this->{ accessToken } && defined $this- +>{ expiresIn } && defined $this->{ time } ) ; return time > ( $this->{ time } + $this->{ expiresIn } - 300 ) ? 1 + : 0 ; } sub setRefreshToken { my $this = shift ; my $refreshToken = shift ; $this->{ refreshToken } = $refreshToken ; $this->{ accessToken } = undef ; $this->{ expiresIn } = undef ; $this->{ time } = undef ; $this->{ tokenType } = undef ; $this->writeJson() ; } sub setAccessToken { my $this = shift ; my $accessToken = shift ; my $expiresIn = shift ; my $tokenType = shift ; my $time = time ; $this->{ accessToken } = $accessToken ; $this->{ expiresIn } = $expiresIn ; $this->{ time } = $time ; $this->{ tokenType } = $tokenType ; $this->writeJson() ; } sub readJson { my $this = shift ; my $fp = shift ; my $fh ; if ( !open $fh, "<", $fp ) { warn "Could not open $fp\n" ; return ; } ; my $json = '' ; while( <$fh> ) { chomp ; $json = $json . $_ ; } close $fh ; my $decoded_json = decode_json( $json ) ; foreach ( keys %{$this} ) { if( $_ =~ /^[^_].*/ ) { $this->{ $_ } = $decoded_json->{ $_ } ; } } } sub writeJson { my $this = shift ; my $json = JSON->new->allow_nonref->convert_blessed ; my $encoded_json = $json->encode( $this ) ; my $fh ; if ( !open $fh, ">", $this->{ _filePath } ) { warn "Write failed to $this->{ _filePath }\n" ; return ; } ; print $fh $encoded_json ; close $fh ; } 1 ;

    And here is the program:

    #!/usr/bin/perl # Copyright (c) 2018 Veltro. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # This package is provided "as is" and without any express or implied # warranties, including, without limitation, the implied warranties of # merchantability and fitness for a particular purpose # # Description: # This program contains TWO examples which can be switched by setting # the internal $method variable to 1 or 2. # This program was shared by me at PerlMonks: # https://www.perlmonks.org/?node_id=1218405 # # Example 1: # Example program that sends an email from your Gmail account using # the Gmail SMTP OAuth 2.0 authenticated Server over TLS # # Example 2: # Example program that sends an email from your Gmail account using # the Gmail API with OAuth 2.0 authentication # # For both examples it is not needed to # - use your Google account password # - to enable 'less secure apps' for Gmail # (Since they use a different authorization mechanism). # # This program has been tested under Windows 10 and Strawberry Perl: # perl 5, version 26, subversion 2 (v5.26.2) built for # MSWin32-x64-multi-thread. # # Preface: After reading a couple of Perl examples that make it # possible to send emails using the Gmail SMTP server I didn't # like the fact that these programs often require user name and # passwords of my Google account. So I started to wonder, is there a # better way? Most of the alternatives that I found where written in # different programming languages such as Python, Java and more. # After doing some research I found out about the possibility to use a # Oauth 2.0 authenticated SMTP server, and I thought I could # potentially turn this into a working Perl program easily. So I # started programming but I found that it was a bit more difficult # than I thought it would be. While programming and getting more # familiar on the subject I also started to realize that using the # Google Gmail API could also be a useful method because it has better # possibilities when using scopes. (The first method can only use one # scope with full access to Gmail: https://mail.google.com/). # So I tried using the API as as well and this resulted in the second # example. Both methods work, but each has it's advantages and # disadvantages. I decided to post both examples on PerlMonks with # this program since I think both methods have some useful elements # that people may want to learn from. I have tried to keep the program # simple and pretty low level on purpose so that it easier to see # what is happening 'under the hood'. The next thing that would # probably be nice to have is sending more complex messages (HTML # format body and messages with attachments). # # Security considerations: # Using OAuth 2.0 authentication in my opinion looks like a better # method than using your Google account password written out # fully inside a program to access the Gmail SMTP server. Your # user name and password would give full access to your Google account # and when compromised would allow your password to be changed. # However, on the subject of using OAuth 2.0 authentication and Google # API's, Google has warnings in multiple occasions like: # - Warning: Keep your client secret private. If someone obtains your # client secret, they could use it to consume your quota, incur # charges against your Google APIs Console project, and request # access to user data. # - Warning: Keep your API key private. If someone obtains your key, # they could use it to consume your quota or incur charges against # your API Console project. # - Warning: Keep refresh and access tokens private. If someone # obtains your tokens, they could use them to access private user # data. # Simply put I think this means: If you feel that the security of your # credentials (in this case the JSON files that contain your secrets, # access tokens and the refresh token) may be compromised, then don't # use these methods! # # When you use the method from example 1, # https://myaccount.google.com/permissions will show: # <Product Name> Has access to: # Gmail # Read, send, delete, and manage your email # So the method used by this program results in full access to Gmail # and not "Full account access". # (See also: https://support.google.com/accounts/answer/3466521). # # For the second method scopes can be altered. See the notes in the # subroutine: getAuthorizationUrlGmail and the difference of the # $scope variable in the program. # When you use the method 2, # https://myaccount.google.com/permissions will show: # <Product Name> Has access to: # Gmail # Send email on your behalf # # Additionally, in my opinion there is one serious flaw in Google's # security system that needs to be considered before using the first # method this program uses. # The method acquires a refresh token to use SMTP that has the scope: # https://mail.google.com/. And it is not possible to use 'incremental # authorization' as in method 2. The scope allows full access to your # Gmail: Read, send, delete, and manage your email. Now here is the # problem: The same refresh token can be used to allow access to Gmail # through other applications interacting with Google's OAuth 2.0 # endpoints. It seems there is no possibility to set boundaries that # tells Google to use the credentials for SMTP only (except for maybe # not enabling the Gmail API)! And as far as I'm concerned this and # the fact that no other scopes (with lower security levels) can be # used this just totally sucks and it is better to take the warnings # from the Google documentation extra serious. # # How to get this program working: # # Prerequisites: # - Packages: JSON, MIME::Lite::TT, Net::SMTP, URL::Encode, # LWP::UserAgent, HTTP::Request::Common # The program comes accompanied with the following modules: # - package Authen::SASL::Perl::XOAUTH2 # To make it possible using Net::SMTP auth() method # location: .\Authen\SASL\Perl\XOAUTH2.pm # - package ClientSecret ; # A very basic JSON reader that can read the JSON client-secret # downloaded from Google # location: .\ClientSecret.pm # - package ClientCredentials # A very basic JSON storage that can read and write the acquired # credentials from and back to disc # location: .\ClientCredentials.pm # # Steps needed for Gmail OAuth 2.0 authentication: # - You need a Google account for these steps # 1. Create a project at Google (https://console.cloud.google.com) # 2. Select your project from the Dashboard and go to 'Credentials' # 3. Select the tab: OAuth consent screen. # The minimum requirement is that you define the product name # So give it the name 'Perl mail' or something like that # 4. Select the credentials tab and click on the 'Create credentials' # button and select: 'OAuth client ID' # 5. Under Application type select: 'other' # 6. Specify the name for the client id. (E.g. 'GmailPerlClientID' ) # 7. Download the client-secret JSON file # 8. (Method 2 only): Activate the Gmail API (and revoke the rights # that you gave to method 1, see security considerations for why). # # Steps needed for this program: # 1. Now that you have downloaded the JSON file, Change the line # 'new $cs ...' and fill in the path to the JSON file # (Note: the JSON file contains redirect uri's, it may be needed # to change the order in which they appear, first the urn # then the one to localhost) # 2. Do the same for 'new $cred ...', and enter a full path to a JSON # file where the credentials are going to be stored. # 3. Execute this program, use the link that is given to you # with a Internet browser and follow the steps to get the # authentication code. # 4. Once you have acquired the authentication code, change the line: # my $authorizationCode = 'Fill in your authorization code here' # 5. Change the following lines with your email address # my $userAuth = 'your email address here' ; # my $to = 'your email address here' ; # 6. Execute this program again. # The program will try to create a new file (step 2) to store the # credentials such as access tokens and refresh tokens. Make sure # that the program can write to this location or it may fail. # 7. You've Got Mail! # # Note: The refresh token may become invalid in certain cases. It # may expire (after 6 months) or it becomes invalid after changing # your password. # # Note: In case you need to create a new authorization code # Set $authorizationCode to '' and delete the client_credentials file # use lib '.' ; use strict ; use warnings ; use ClientSecret ; use ClientCredentials ; use MIME::Lite::TT ; use Net::SMTP ; use URL::Encode qw(url_encode) ; use LWP::UserAgent ; use HTTP::Request::Common ; use JSON ; use MIME::Base64 ; use Data::Dumper ; # Activate this line to debug SSL: # use IO::Socket::SSL qw(debug4); # Set this to 1 to debug SMTP: my $dbgSMTP = 0 ; my $method = 1 ; my $userAuth = 'Your Gmail address here' ; my $to = 'Your Gmail address here' ; my $from = 'me' ; # Download Google OAuth 2.0 client secret JSON file and fill in the # full path here; my $cs = new ClientSecret( q{.\client_secret_xxxxxxxxxxxxx-xxxxxxxxxxx +xxxxxxxxxxxxxxxxxxxxx.apps.googleusercontent.com.json}) ; die "Failed to read client secret\n" unless ( $cs ) ; # Specify the full path to credentials storage location here (.json): my $cred = new ClientCredentials( q{.\client_credentials_xxxxxxxxxxxxx +-xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx.apps.googleusercontent.com.json}) ; # Fill in your authorization code here my $authorizationCode = 'Fill in your authorization code here' ; # Get the refresh token if needed if ( $cred->refreshTokenNeeded ) { if ( $authorizationCode eq 'Fill in your authorization code here' || $authorizationCode eq '' ) { # Authorization code needed. Follow link, accept and copy the # authorization code to this program in $authorizationCode my $scope = 'https://mail.google.com/' ; if ( $method == 2 ) { $scope = 'https://www.googleapis.com/auth/gmail.send' ; # $scope = 'https://www.googleapis.com/auth/gmail.insert' ; } my $aUrl = getAuthorizationUrlGmail( $cs, $scope ) ; print "Get your authorization code here:\n" . $aUrl . "\n\n" ; print "Change \$authorizationCode to the acquired code from Go +ogle\n" ; exit( 0 ) ; } else { # Get the refresh token (and access token) getRefreshToken( $cs, $cred, $authorizationCode ) ; } } # Check if a refresh is needed if ( $cred->expired ) { refresh( $cs, $cred ) ; } sub getAuthorizationUrlGmail { # IN: ClientSecret object # IN: scope (See: # https://developers.google.com/gmail/api/auth/scopes) # OUT: URL to insert into your browser to retrieve the # authorization code my $cs = shift ; my $scope = shift ; my $url = "$cs->{ authUri }?" . "client_id=" . url_encode( $cs->{ clientID } ) . "&redirect_uri=" . url_encode( $cs->{ redirectUris }[0] ) . "&scope=" . url_encode( $scope ) . "&response_type=code" ; return $url ; } sub getRefreshToken { my $cs = shift ; my $cred = shift ; my $authorizationCode = shift ; my $url = $cs->{ tokenUri } ; my $ua = LWP::UserAgent->new ; my $response = $ua->request( POST $url, [ client_id => $cs->{ clientID }, client_secret => $cs->{ clientSecret }, code => $authorizationCode, # Redirect to urn, (takes first urn in JSON) redirect_uri => $cs->{ redirectUris }[0], grant_type => 'authorization_code' ] ) ; my $decoded_json = decode_json($response->decoded_content); my $accessToken = $decoded_json->{ 'access_token' } ; my $expiresIn = $decoded_json->{ 'expires_in' } ; my $refreshToken = $decoded_json->{ 'refresh_token' } ; my $tokenType = $decoded_json->{ 'token_type' } ; $cred->setRefreshToken( $refreshToken ) ; $cred->setAccessToken( $accessToken, $expiresIn, $tokenType ) ; } sub refresh { my $cs = shift ; my $cred = shift ; my $url = $cs->{ tokenUri } ; my $ua = LWP::UserAgent->new ; my $response = $ua->request( POST $url, [ client_id => $cs->{ clientID }, client_secret => $cs->{ clientSecret }, refresh_token => $cred->{ refreshToken }, grant_type => 'refresh_token' ] ) ; my $decoded_json = decode_json($response->decoded_content); my $accessToken = $decoded_json->{ 'access_token' } ; my $tokenType = $decoded_json->{ 'token_type' } ; my $expiresIn = $decoded_json->{ 'expires_in' } ; $cred->setAccessToken( $accessToken, $expiresIn, $tokenType ) ; } # Create MIME::Lite::TT email message my %params ; $params{first_name} = 'Veltro' ; my %options ; $options{INCLUDE_PATH} = './templates' ; my $msg = MIME::Lite::TT->new( # From/to may not be used, but then only BCC will be filled in # instead. Using from/to here then Gmail finds my email # 'important' according to the magical formulas of Google. From => $from, To => $to, Subject => 'Test email from Perl', Template => 'test.txt.tt', TmplOptions => \%options, TmplParams => \%params, ) ; ######################## METHOD 1 #################################### if ( $method == 1 ) { # use NET::SMTP instead of $msg->send: # - Gmail = smtp.gmail.com # - Port 465 = SSL, is also ok, but then do not starttls and set # initial connection with option 'SSL => 1' # - Port 587 = TLS my $smtp = Net::SMTP->new( 'smtp.gmail.com', Port=>587, SendHello => 0, Debug => $dbgSMTP ) ; if ( !( defined $smtp ) ) { print "Failed to connect, reason=$@\n" ; exit( 1 ) ; } # HELLO # Reminder: hello is also send again after starttls $smtp->hello( $cs->{ clientID } ) or die "Error: " . $smtp->message() ; # STARTTLS if ( !$smtp->starttls() ) { if ( ref $smtp eq 'Net::SMTP' ) { die "NET::SMPT failed to upgrade connection after connecti +on message: " . $smtp->message() . "Possible reasons for this may be firewalls or antivirus p +rotection software (such as mail shields). You can activate debugging + for IO::Socket::SSL and \$dbgSMTP to search for other possible reaso +ns\n" ; } else { die "starttls failed with Error: " . $smtp->message() . "You can activate debugging for IO::Socket::SSL and \$dbgS +MTP to search for possible reasons\n" ; } } ; # AUTHENTICATE use Authen::SASL qw( Perl ) ; my $sasl = Authen::SASL->new( mechanism => 'XOAUTH2', callback => { user => $userAuth, auth => $cred->{ tokenType }, access_token => $cred->{ accessToken }, } ) ; $smtp->auth($sasl) or die "Can't authenticate:" . $smtp->message() + ; # ($smtp->message)[0] should contain something like: 2.7.0 Accepte +d # MAIL (= From) $smtp->mail( $from ) or die "Error: " . $smtp->message() ; # TO $smtp->to( $to ) or die "Error: " . $smtp->message() ; # DATA - DATASEND - DATAEND - QUIT $smtp->data() or die "Error: " . $smtp->message() ; $smtp->datasend( $msg->as_string ) or die "Error: " . $smtp->message() ; $smtp->dataend() or die "Error: " . $smtp->message() ; $smtp->quit() or die "Error: " . $smtp->message() ; if($@) { print STDERR "Error sending mail: $@"; } } ######################## METHOD 2 #################################### if ( $method == 2 ) { my $msg64 = encode_base64( $msg->as_string, '' ) ; my %jsonraw = ( raw => $msg64 ) ; use LWP::Protocol::http ; push( @LWP::Protocol::http::EXTRA_SOCK_OPTS, PeerHTTPVersion => 1.1 ) ; my $ua = LWP::UserAgent->new( keep_alive => 1, send_te => 0 ) ; my @ns_headers = ( 'Connection' => 'Keep-Alive', 'Content-Type' => 'application/json', 'Authorization' => "Bearer $cred->{ accessToken }", ) ; # scope could be : https://mail.google.com # or better : https://www.googleapis.com/auth/gmail.send my $uri = 'https://content.googleapis.com/gmail/v1/users/me/messag +es/send' ; # scope could be: 'https://www.googleapis.com/auth/gmail.insert' # my $uri = 'https://content.googleapis.com/gmail/v1/users/me/mess +ages' ; # Not so useful, message is created but does not appear in Inbox my $json = JSON->new ; my $encoded_json = $json->encode( \%jsonraw ) ; my $req = HTTP::Request->new( 'POST', $uri ) ; $req->header( @ns_headers ) ; $req->content( $encoded_json ) ; my $response = $ua->request( $req ) ; # This also works but I prefer a cleaner header # my $lwp = LWP::UserAgent->new ; # $lwp->request( $req ) ; # Enable this for debugging. The API sometimes shows pretty # useful error messages # print Dumper( $response ) ; }
Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (10)
As of 2018-07-18 13:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    It has been suggested to rename Perl 6 in order to boost its marketing potential. Which name would you prefer?















    Results (393 votes). Check out past polls.

    Notices?