Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
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
Is this a valid approach to finding if a path through a set of points has completed?
2 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.)

-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

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(<TEST>){ if(/test/ and $flag eq "ON"){print "start";$flag ="OFF"}} close TEST
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

Regex to pull out string within parenthesis that could contain parenthesis
8 direct replies — Read more / Contribute
by dpelican
on Jul 09, 2018 at 09:45

    I'm working on a way to automate comment generation for some code that I'm working on and I'm trying to extract parameters from a function declaration. I came up with the following expression:

     ^(private|public)?\s?(function|report)\s([^()]+)\(([^()]+)?\)(\s(returns)\s\(?([^()]+)\)?)?

    The expression worked on almost all functions until the parameters contained parentheses themselves, such as:

    function convert_wa_date_strings(iv_beg string, iv_end string, iv_read_date date, iv_step char(6)) returns (date, date, char(1))

    Since the parentheses are important for the variable type they can't be ignored. The same issue occurs with the returns, but it'll be the same fix. What is it that I'm missing to capture those pesky parameters with parentheses?

    Thanks!

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 chilling in the Monastery: (6)
As of 2018-07-16 11:01 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 (333 votes). Check out past polls.

    Notices?