### The Monastery Gates

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

and Create a new user.

New Questions
 IF condition with a range 4 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) [download]``` Is there a more compact way to write this? Thanks! Print inside SIGNALS 3 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"; } [download]``` 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): Incomplete connection - existing connections are 1-2 and 2-3. Incomplete connection - existing connections are 1-2, 2-3, 4-5, 5-6, and 1-6 Incomplete connection - existing connections are 1-2, 2-3, 4-5, 5-6, and 1-6, extra connection 4-6 Complete connection - existing connections are 1-2, 2-3, 3-4, 4-5, 5-6, and 1-6 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: Read more... (425 Bytes) (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.) Read more... (681 Bytes) 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: Read more... (5 kB) 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? No replies — Read more | Post response 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); [download]``` 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. ``` \((.*?)\) [download]``` How can I catch things except what is inside? below matches everything except "(" and ")" ``` [^()] [download]``` 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"; [download]``` 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 flag function 5 direct replies — Read more / Contribute by dideod.yang on Jul 11, 2018 at 06:57 Hi monks. I have a question about function. I code some script using perl often. Below script, script open text file that include many words 'test'. but I want to print only one when script meet 'test' at first. so I always use \$flag. however that script looks bad and uncomfortable. Can you recommand new functions? or tips? about that issue?? ```open TEST,"@ARGV[0]"; \$flag ="ON" while(){ if(/test/ and \$flag eq "ON"){print "start";\$flag ="OFF"}} close TEST [download]``` Configuring perl such that HAS_STRTOD is not defined 2 direct replies — Read more / Contribute by syphilis on Jul 10, 2018 at 20:43 Hi, Whenever I build a modern perl on Linux, the symbol HAS_STRTOD (in the C source) is defined, as also is \$Config{d_strtod}. Is there a command line option that I can provide to "sh Configure" that will set HAS_STRTOD (and therefore also \$Config{d_strtod}) to undef ? Cheers,Rob Regex to catch IPV4 and IPV6 whenever ip appears withing brackets 5 direct replies — Read more / Contribute by theravadamonk on Jul 10, 2018 at 00:13 My maillog has IPV4 and IPV6 addresses withing brackets. I am trying to write a regex to catch ONLY IPV4 and IPV6 when they appear withing brackets. (IPV6 may be compressed or decompressed) Pls keep in mind that My maillog begins with time stamp like this. 2018 Jun 26 09:05:15 ( It has : and IPV6 also has it ) how IPs appear in maillog file. (209.85.208.68) (172.217.194.27 < 209.85.208.68) (172.217.194.27 < 2001:4860:4860:0:0:0:0:8888) (2001:4860:4860:0:0:0:0:8888) (2001:4860:4860:0:0:0:0:8888 < 2001:4860:4860::8844) (2001:4860:4860:0:0:0:0:8888 < 172.217.194.27) Sometimes, it appears in this way too. It may have IPV6 as well. (172.217.194.27 < 172.217.194.27 < 209.85.208.68) Anyway, I stared with below. It won't fulfill. It can catch ipv4  [\(\d+\.\d+\.\d+\.\d+ \<\)]+ Shall we Try? this may be a tiny task for Perl monks. I hv been writing since yesterday. Hope to hear from you
New Meditations
 use Memoize; 1 direct reply — 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 ; [download]``` 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, [download]``` 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 ; [download]``` ```#!/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 ; [download]``` 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: # 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: # 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 ) ; } [download]```

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: (6)
As of 2018-07-17 04:11 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 (354 votes). Check out past polls.

Notices?