Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

Cool Uses for Perl

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

This section is the place to post your general code offerings -- everything from one-liners to full-blown frameworks and apps.

CUFP's
Windows Automation by Sparrowdo
No replies — Read more | Post response
by melezhik
on Sep 11, 2018 at 10:36
    Sparrowdo is a universal task runner and CM tool written on Perl6/Perl5. It enables configuration and automation tasks with efficient and simple way. I have created a fresh post on dev.to introducing Sparrowdo automation for Windows OS. Everyone is interested in Windows automation by Perl5/Perl6 are welcome to read.
A hash that stores itself between runs
No replies — Read more | Post response
by Anonymous Monk
on Sep 06, 2018 at 10:53
    This is so small compared to the rest of the posts here in CUFP, I hesitated for a while before deciding to submit anyway:
    package cache { # no particular reason to use them, # but the syntax sugar is *so* sweet use experimental 'signatures'; use base 'Storable'; my %paths; sub new($class,$path) { my $self = eval { return Storable::retrieve($path) } || bless {}, $class; $paths{$self} = $path; return $self; } sub DESTROY($self) { $self->store($paths{$self}); } }
    How to use:
    • create the object as you usually would: my $cache = cache::->new("store.db");
    • anywhere you might find it useful to cache results in a hash between runs of a function, use defined-or assignment to retrieve the value if it's already cached: my $val = $cache->{$argument} //= func($argument);
    • next time you run the script again the cached values are still there, no need to recalculate
    • combine with memoization for best results
    The class uses inside-out objects so you could use objects as ordinary hashes with no reserved fields. This will get slower the bigger your cache gets because there is no RLU eviction, everything is stored in memory and the whole store has to be loaded from disk on startup and serialised on shutdown. Still, for small scripts I find it useful.
Creating random sentences from a dictionary
4 direct replies — Read more / Contribute
by Lotus1
on Sep 04, 2018 at 17:15

    Here's a bit of random nonsense. Create a random number of lines with a random number of random words from a dictionary. Repeated words are acceptable.

    use strict; use warnings; my @words = <DATA>; chomp @words; my $number_of_sentences = 3 + int( 10*rand() ); for (1..$number_of_sentences) { my $sentence_length = 2 + int( 9*rand() ); my @sentence = map {$words[int(rand($#words+1))]} 1..$sentence_len +gth; $sentence[0] = ucfirst $sentence[0]; print join(" ", @sentence), ".\n\n"; } __DATA__ abnormal blah crazy dolt dolthead doltish doltishly doltishness eccentric fallacious galling hapless illogical jabber kooky lame misguided nuisance officious pretense questionable resentful shaky tenuous untenable vague warp yawn zombie

    The output from a run was:

    Doltishly yawn yawn. Shaky warp yawn tenuous misguided illogical doltish. Warp blah officious kooky dolthead untenable eccentric untenable offic +ious. Galling officious. Abnormal doltish hapless tenuous. Galling crazy. Abnormal galling doltish. Kooky crazy doltishly doltishness. Eccentric blah fallacious galling. Pretense untenable questionable abnormal kooky zombie dolt jabber.
WebPerl Regex Tester (beta)
2 direct replies — Read more / Contribute
by haukex
on Sep 04, 2018 at 15:27

    I recently published a beta of WebPerl, and now I've written my first full web app with it: a browser-based regex tester.

    Since WebPerl is a full build of Perl, you have the full power of core Perl at your disposal, and it runs entirely in the browser - unlike some other online regex testers, which either run perl on a server, or only support PCRE (Perl Compatible Regular Expressions). It should work in modern browsers like Firefox and Chrome (not tested in IE yet, it might have issues there). Try it out, and let me know what you think, and report any issues you might find. I'd also be happy to accept issues and patches on GitHub. Please consider it a beta.

    http://webperl.zero-g.net/regex.html
    (It may take a few seconds to load and initialize, WebPerl is currently a ~4MB download, but once it's in your cache it should be fine.)

    You can even create URLs to examples, here I'll use that to show off some features:

Tk Morse Code Ear tutor
2 direct replies — Read more / Contribute
by zentara
on Aug 26, 2018 at 13:12
    Hi, another Perl/Tk app. :-) Any comments or improvements welcome. The details are at the top of the script. Basically, this tutor forces you to use your ear to recognize letters, forcing the brain to make a direct auditory connection to the letter. It also demonstrates how to make PCM tones of any frequency and duration without the obsolete /dev/dsp.


    I'm not really a human, but I play one on earth. ..... an animated JAPH
Exploring Type::Tiny Part 5: match_on_type
No replies — Read more | Post response
by tobyink
on Aug 19, 2018 at 14:41

    Type::Tiny is probably best known as a way of having Moose-like type constraints in Moo, but it can be used for so much more. This is the fifth in a series of posts showing other things you can use Type::Tiny for. This article along with the earlier ones in the series can be found on my blog and in the Cool Uses for Perl section of PerlMonks.

    It's pretty common to do things like this:

    use Types::Standard qw( is_ArrayRef is_HashRef ); use Carp qw( croak ); sub process_data { my ($self, $data) = @_; if (is_ArrayRef($data)) { $self->_process_value($_) for @$data; } elsif (is_HashRef($data)) { $self->_process_value($_) for values %$data; } else { croak "Could not grok data"; } }

    Type::Utils provides a perhaps slightly neater way to do this:

    use Types::Standard qw( ArrayRef HashRef Any ); use Type::Utils qw( match_on_type ); use Carp qw( croak ); sub process_data { my ($self, $data) = @_; match_on_type $data, ArrayRef, sub { $self->_process_value($_) for @$data }, HashRef, sub { $self->_process_value($_) for values %$data } +, Any, sub { croak "Could not grok data" }; }

    The match_on_type function takes a value and a set of type–coderef pairs, dispatching to the first coderef where the value matches the type constraint. This function is stolen from Moose::Util::TypeConstraints.

    You can get an order of magnitude faster though by doing something similar to what Type::Params does — compiling the match once, then calling it as needed.

    Let's look at a naïve (and wrong) way to do this first and examine the problems:

    use Types::Standard qw( ArrayRef HashRef Any ); use Type::Utils qw( compile_match_on_type ); use Carp qw( croak ); sub process_data { my ($self, $data) = @_; state $matcher = compile_match_on_type ArrayRef, sub { $self->_process_value($_) for @$data }, HashRef, sub { $self->_process_value($_) for values %$data } +, Any, sub { croak "Could not grok data" }; $matcher->($data); }

    The big problem here is that the first time process_data is called, the matcher will close over $self and $data. Subsequent calls to $matcher will reuse the same closed over variables. Oops.

    The simplest way of solving this is to take advantage of the fact that a compiled matcher (unlike match_on_type) can take a list of arguments, not just one. Only the first argument is used for the type matching, but all arguments are passed to the coderefs on dispatch.

    use Types::Standard qw( ArrayRef HashRef Any ); use Type::Utils qw( compile_match_on_type ); use Carp qw( croak ); sub process_data { my ($self, $data) = @_; state $matcher = compile_match_on_type ArrayRef, sub { my ($d, $s) = @_; $s->_process_value($_) for +@$d }, HashRef, sub { my ($d, $s) = @_; $s->_process_value($_) for +values %$d }, Any, sub { croak "Could not grok data" }; $matcher->($data, $self); }

    Like many Type::Tiny interfaces that expect coderefs, compile_match_on_type also accepts strings of Perl code as an alternative, and is able to optimize things better if those are supplied:

    use Types::Standard qw( ArrayRef HashRef Any ); use Type::Utils qw( compile_match_on_type ); use Carp qw(); sub process_data { my ($self, $data) = @_; state $matcher = compile_match_on_type ArrayRef, q{ my ($d, $s) = @_; $s->_process_value($_) for @$d + }, HashRef, q{ my ($d, $s) = @_; $s->_process_value($_) for val +ues %$d }, Any, q{ Carp::croak("Could not grok data") }; $matcher->($data, $self); }

    The coderefs compiled by compile_match_on_type should be very efficient. The technique is very similar to how Type::Coercion compiles coercions.

Proxying (almost) all methods in a class for mass memoization
1 direct reply — Read more / Contribute
by Tommy
on Aug 15, 2018 at 20:08

    If this could be done in a 'better' way, I'd enjoy hearing it. Criticisms welcome.

    Recently needed to basically cache the output of almost every class method in one of my modules that is part of a web app. Every method runs a different database query and encodes the results to JSON. The results change daily, so upstream of the module implementation there is logic that enforces a 12 hour TTL for anything any method returns. In the interim time though, there's no reason for the app to run these database queries at all when it already did the work. Reading about possible approaches to the problem on stack overflow yesterday I saw that use of autoload was discouraged, so this is what I came up with and as far as I can tell, after running two days in DEV, it appears to have no issues. I'm actually quite pleased, because this approach allowed me to be 'clever' without an implementation that is unmaintainable and unintelligible by others... Gist here

    use strict; use warnings; package My::Class::Proxy; # Drop-in replacement for 'Some Class' # Proxies all public method calls to Some::Class in order to provide s +mart # caching and memoization, e.g.- avoiding expensive DB queries when no +t required use 5.020; use Moose; extends 'Some::Class'; use Moose::Util qw(); my $meta = Moose::Util::find_meta( 'Some::Class' ); my @nocache = qw( new meta DESTROY AUTOLOAD ); state $outputs = {}; for my $method ( $meta->get_method_list ) { # don't memo-ize blaclisted or private methods next if ( grep { $_ eq $method } @nocache or $method =~ /^_/ ); around $method => sub { my ( $orig, $self, $refresh, @args ) = @_; $outputs = {} if !!$refresh; @args = map { $_ // '' } @args; my $call_key = join '', $orig, @args; return $outputs->{ $call_key } if defined $outputs->{ $call_key +}; $outputs->{ $call_key } = $self->$orig( @args ); return $outputs->{ $call_key }; }; } # Moose-specific optimization __PACKAGE__->meta->make_immutable(); 1;

    Tommy
    A mistake can be valuable or costly, depending on how faithfully you pursue correction
Remote shell via ssh
2 direct replies — Read more / Contribute
by BernieC
on Aug 14, 2018 at 18:42

    I've been fighting with Net::SSH2 trying to get it to do simple stuff -- in particular all I needed was for it to be ablet execute commands on the server. I've gotten it all working {the biggest hangup was that, apparently, password auth doesn't work in Net::SSH2 and switching to public_key make things magically work}. Here's the skeleton of a little program that'll execute shell commands:

    #!/usr/bin/perl # run shell commands remotely over an SSH connection use strict; use warnings ; use Net::SSH2 ; use constant HOST => "YOURHOST" ; use constant USER => "YOURLOGIN" ; use constant HOSTKEY => "Path to your known_hosts keys file" ; ## To enable the public key login, append your 'pub' key file to the ## authorized_keys file in ~/.ssh on the server use constant PUBLICKEY => "Path to your public key" ; use constant PRIVATEKEY => "path to your private key" ; # Set up the SSH connection my $ssh2 = Net::SSH2->new() ; $ssh2->connect(HOST) or $ssh2->die_with_error ; $ssh2->check_hostkey(tofu => HOSTKEY) or $ssh2->die_with_error ; $ssh2->auth_publickey(USER, PUBLICKEY, PRIVATEKEY) or $ssh2->die_with_error ; $ssh2->auth_ok() ; # Logged in -- now you can execute commands print docmd("cd bin; ls") ; $ssh2->disconnect() ; exit ; # do the command and return the output ## NB: you can only do one command on a channel so we get a channel ## do the command, collect the output and close the channel ## The command must be a fully "punctuated and escaped" shell comman +d. sub docmd { my $chan = $ssh2->channel() or $ssh2->die_with_error ; $chan->exec("($_[0]) 2>&1") ; my $out = ""; while (!$chan->eof) { my $buffer = ""; if (not defined ($chan->read($buffer, 100))) { $ssh2->die_with_error() ; } $out .= $buffer ; } return $out ; }
Exploring Type::Tiny Part 4: Using Types::Standard as a Ref::Util-Like Library
No replies — Read more | Post response
by tobyink
on Aug 12, 2018 at 11:50

    Type::Tiny is probably best known as a way of having Moose-like type constraints in Moo, but it can be used for so much more. This is the third in a series of posts showing other things you can use Type::Tiny for. This article along with part 1, part 2, and part 3 can be found on my blog and in the Cool Uses for Perl section of PerlMonks.

    Even if you read the documentation of Types::Standard pretty thoroughly, you'd probably miss that you can do things like this:

    use Types::Standard qw(is_ArrayRef is_HashRef); if (is_ArrayRef($var)) { ...; } elsif (is_HashRef($var)) { ...; }

    It is documented that Types::Standard exports functions called ArrayRef and HashRef, which are constant-like functions returning Moose/Moo-compatible type constraint objects, but where did these is_ArrayRef and is_HashRef functions come from?

    Well, their existence is documented in Type::Library, the type library base class used by Types::Standard. Any type library built with it will offer is_* variants of type constraints. These functions check their argument and return a boolean indicating whether it passes the type constraint.

    The object-oriented way of writing these checks is like this:

    use Types::Standard qw(ArrayRef HashRef); if (ArrayRef->check($var)) { ...; } elsif (HashRef->check($var)) { ...; }

    Though the object-oriented way is a little slower because it will result in at least three sub calls (including a method call).

    The is_* functions should be pretty darn fast, especially if Type::Tiny::XS is installed. Ref::Util::XS is faster, and Params::Util is sometimes faster, but using Type::Library-based type libraries (such as Types::Standard, Types::Common::Numeric, Types::Common::String, Types::Path::Tiny, Types::XSD, etc) will give you a richer selection of types that you can check.

    Assertions

    A common use for type checking functions is to do something like:

       is_ArrayRef($var) or die(...);

    Type::Library-based type libraries offer a shortcut for this:

       assert_ArrayRef($var);

    The return value of the assert_* functions (if they don't die) is the parameter you passed to them, which makes it convenient to do things like:

    use Types::Standard qw(assert_Object assert_ArrayRef); sub process_data { my $self = assert_Object( $_[0] ); my $data = assert_ArrayRef( $_[1] ); ...; }

    The object-oriented equivalent of assert_Object($thing) is Object->assert_return($thing). Due to overloading Object->($thing) will also work.

    Coercions

    If a type constraint has coercions (like Path from Types::Path::Tiny), there's also a to_* function:

    use Types::Path::Tiny qw( to_Path ); my $path = to_Path($thing);

    Note that if a coercion fails, there is no exception thrown, and the original value is passed through unaltered. If you want to make sure coercion succeeded:

    use Types::Path::Tiny qw( assert_Path to_Path ); my $path = assert_Path( to_Path($thing) );

    The object-oriented equivalent of to_Path($thing) is Path->coerce($thing). The object-oriented equivalent of assert_Path(to_Path($thing)) is Path->assert_coerce($thing).

    Parameterized Types

    It would be pretty cool if you could do:

    if (is_ArrayRef[Int]($var)) { ...; }

    But that wouldn't be syntactically valid Perl.

    You can do this though:

    use Types::Standard qw(ArrayRef Int); BEGIN { my $type = ArrayRef->of(Int); *is_ArrayRef_of_Int = $type->compiled_check; *assert_ArrayRef_of_Int = \&{ $type }; *to_ArrayRef_of_Int = sub { $type->coerce(@_) }; } if (is_ArrayRef_of_Int($var)) { ...; }

    Exporting Tricks

    To export just Object:

       use Types::Standard qw(Object);

    To export just is_Object:

       use Types::Standard qw(is_Object);

    To export Object and is_Object:

       use Types::Standard qw(Object is_Object);

    To export Object and all related functions (is_Object, assert_Object, and to_Object):

       use Types::Standard qw(+Object);

    To export Object, ArrayRef, and all the other types:

       use Types::Standard qw(:types);

    To export Object, ArrayRef, all the other types, and the related is_* functions:

       use Types::Standard qw(:types :is);

    To export Object, ArrayRef, all the other types, and the related is_*, assert_*, and to_* functions:

       use Types::Standard qw(:types :is :assert :to);
Exploring Type::Tiny Part 3: Using Type::Tie
No replies — Read more | Post response
by tobyink
on Aug 08, 2018 at 13:02

    Type::Tiny is probably best known as a way of having Moose-like type constraints in Moo, but it can be used for so much more. This is the third in a series of posts showing other things you can use Type::Tiny for. This article along with part 1 and part 2 can be found on my blog and in the Cool Uses for Perl section of PerlMonks.

    This works:

    use Types::Standard qw(Int); tie(my @numbers, Int); push @numbers, 1, 2, 3; # ok push @numbers, "four"; # dies

    Well, if you try it, you may find it complains about not being able to load Type::Tie.

    Type::Tie is an add-on for Type::Tiny distributed separately. It's an optional dependency, so if you want to use this feature, you'll need to make sure it's installed.

    Coercions

    This tie feature automatically supports coercions.

    use Types::Standard qw(Int Num); my $RoundedInt = Int->plus_coercions( Num, 'int $_' ); tie(my @numbers, $RoundedInt); push @numbers, 1, 2, 3; # ok push @numbers, 4.2; # rounded to 4 push @numbers, "five"; # dies

    More about Type::Tie

    Type::Tie is designed to be pretty independent of Type::Tiny. You can use it with MooseX::Types, Mouse::Types, and Specio, and it also bundles its own nanoscale type constraint library Type::Nano.

    use Type::Tie qw(); use MooseX::Types::Moose qw(Int); tie(my @numbers, "Type::Tie::ARRAY", Int);

    To save yourself typing "Type::Tie::ARRAY", "Type::Tie::HASH", and "Type::Tie::SCALAR" all the time, Type::Tie offers a convenience function ttie:

    use Type::Tie qw(ttie); use MooseX::Types::Moose qw(Int); ttie(my @numbers, Int);

    Use in Attributes

    Perl has a type checking hole thanks to references:

    use v5.16; package Foo { use Moo; use Types::Standard qw(ArrayRef Int); has numbers => ( required => 1, is => 'ro', isa => ArrayRef[Int], ); } my $foo = Foo->new( numbers => [1, 2, 3] ); push @{ $foo->numbers }, "hi"; # this is allowed

    The type constraint is only checked in the constructor and in writers/accessors.

    Tying the array allows you to perform type checks and coercions on any new elements added to the array. It's a use for trigger that doesn't suck!

    use v5.16; package Foo { use Moo; use Types::Standard qw(ArrayRef Int); has numbers => ( required => 1, is => 'ro', isa => ArrayRef[Int], trigger => sub { tie @{$_[1]}, Int }, ); } my $foo = Foo->new( numbers => [1, 2, 3] ); push @{ $foo->numbers }, "hi"; # dies

    With a little bit of work (okay, a lot!) it should be possible to even check deeply nested structures.

    Performance

    While effort has been made to optimize Type::Tie, tied variables are necessarily slower than untied ones.

    If you have an array you want to make sure only contains integers, but you don't want to compromise on performance, you could enable the tie only when you run your test suite, and trust that your test suite will be enough to trigger any potential errors.

    use Types::Standard qw(Int); use Devel::StrictMode qw(STRICT); my @array_of_ints; tie @array_of_ints, Int if STRICT; ...; # do stuff here

    Devel::StrictMode is a module which exports a constant called STRICT which will be true if the PERL_STRICT, EXTENDED_TESTING, RELEASE_TESTING, or AUTHOR_TESTING environment variables is true, and false otherwise.

Exploring Type::Tiny Part 2: Using Type::Tiny with Moose
1 direct reply — Read more / Contribute
by tobyink
on Aug 04, 2018 at 10:09

    Type::Tiny is probably best known as a way of having Moose-like type constraints in Moo, but it can be used for so much more. This is the second in a series of posts showing other things you can use Type::Tiny for. Part 1 can be found at http://blogs.perl.org/users/toby_inkster/2018/07/exploring-typetiny-part-1-using-typeparams-for-validating-function-parameters.html.

    Type::Tiny is often used in Moo classes and roles as a drop-in replacement for Moose's built-in type system. But the original reason I wrote it was as a response to the growing number of MooseX::Types and MouseX::Types modules on CPAN. I thought "wouldn't it be good if you could write a type library once, and use it for Moose, Mouse, and maybe even Moo?" In the very early version, you needed to import types like this:

    use Type::Standard -moose, qw(Int); use Type::Standard -mouse, qw(Int); use Type::Standard -moo, qw(Int);

    Specifying which object system you were using allowed the type library to export different blessed type constraint objects for different object frameworks. Eventually this need was eliminated by having Type::Tiny's objects better mock the Moose and Mouse native APIs, so the frameworks didn't even notice you weren't using their built-in type constraints.

    (While no longer documented, the -moose, etc import flags still work in all Type::Library-based type libraries.)

    Anyway, so now you know Type::Tiny types can work with Moose, what are the reasons to use them over Moose's built-in type constraints?

    Type::Tiny is Faster

    In almost all cases, Type::Tiny checks and coercions run faster than the built-in Moose ones.

    use v5.16; use Benchmark qw(cmpthese); BEGIN { $ENV{PERL_TYPE_TINY_XS} = 0; } package Example::Native { use Moose; has numbers => ( is => 'rw', isa => 'ArrayRef[Str]', ); __PACKAGE__->meta->make_immutable; } package Example::TT { use Moose; use Types::Standard qw(ArrayRef Str); has numbers => ( is => 'rw', isa => ArrayRef[Str], ); __PACKAGE__->meta->make_immutable; } cmpthese -1, { native => q{ my $obj = Example::Native->new(numbers => []); $obj->numbers([0 .. $_]) for 1 .. 50; }, tt => q{ my $obj = Example::TT->new(numbers => []); $obj->numbers([0 .. $_]) for 1 .. 50; }, }; __END__ Rate native tt native 2511/s -- -45% tt 4525/s 80% --

    Note that even without XS, the Type::Tiny checks run 80% faster than Moose's native ones. If Type::Tiny::XS is available, it's about 400% faster. (Yeah, I could have tested ArrayRef[Int] but sadly the Int type is one of the slower type checks in Types::Standard, no faster than Moose.)

    Type::Tiny has a Better Coercion Paradigm

    In Moose, if you want to, say, coerce an arrayref of strings into a single string, then the usual way to do it is something like this:

    use Moose::Util::TypeConstraints; coerce 'Str', from 'ArrayRef', via { join "\n", @$_ };

    However, this has a global effect. It doesn't just apply to string attributes in your class, but any string attributes which have coercion enabled for them.

    While Type::Tiny does support globally defined coercions for Moose compatibility, the practice above, of adding your own coercions to types in standard libraries is strongly discouraged.

    Instead, two routes to coercions are recommended.

    Firstly, if you're making your own type library, feel free to define any useful coercions to the types in that library. Some of the type libraries bundled with Type::Tiny do include a few standard coercions. For example LowerCaseStr in Types::Common::String defines a coercion from non-empty strings (passing the string to Perl's lc function).

    Secondly, if you're consuming types from a library (importing them into your role or class for use), don't add your own coercions to them. Instead, use the plus_coercions method.

    package MyClass { use Moose; use Types::Standard qw(ArrayRef Str); has data => ( is => 'ro', isa => Str->plus_coercions(ArrayRef, sub { join "\n", @$_ +}), ); }

    What does this do? Instead of adding coercions to the global definition of Str, it transparently creates a subtype of Str and adds your coercions to that.

    There's also plus_fallback_coercions (which does the same thing but gives priority to any existing coercions the type constraint already has), minus_coercions (to remove particular existing coercions from a type), and no_coercions (to give you a blank slate).

    Coercions can also be defined using strings of Perl code:

       Str->plus_coercions(ArrayRef, q{ join "\n", @$_ })

    This allows them to be better optimized.

    Type::Tiny Makes Subtyping a Breeze

    package MyClass { use Moose; use Types::Standard qw(Int); has even_number => ( is => 'ro', isa => Int->where(sub { $_ % 2 == 0 }), ); }

    Need I say more?

    Probably not.

    But I'll add that again, you can use a string of Perl code to get slightly better performance.

    Type::Tiny and MooseX::Types Interoperate Fine

    package MyClass { use Moose; use Types::Standard qw(ArrayRef); use MooseX::Types::Moose qw(Int); has will_this_work => ( is => 'ro', isa => ArrayRef[Int], ); }

    Yeah, it works.

    Validate Method Parameters

    In part 1 of this series I described how you can use Type::Tiny type constraints to validate data passed to functions. If you're checking incoming data to your accessors and constructors, why not check parameters passed to method calls as well? Type::Params lets you use the same types and coercions you're familiar with from defining attributes to validate method parameters.

    use v5.16; package MyClass { use Moose; use Types::Standard qw(Object Int); use Type::Params qw(compile); my $EvenInt = Int->where(sub { $_ % 2 == 0 }); has even_number => ( is => 'ro', isa => $EvenInt, writer => '_set_even_number', ); sub add_another_even { state $check = compile(Object, $EvenInt); my ($self, $n) = &$check; $self->_set_even_number( $self->even_number + $n ); return $self; } }
Exploring Type::Tiny Part 1: Using Type::Params for Validating Function Parameters
No replies — Read more | Post response
by tobyink
on Jul 30, 2018 at 14:49

    Type::Tiny is probably best known as a way of having Moose-like type constraints in Moo, but it can be used for so much more. This is the first in a series of posts showing other things you can use Type::Tiny for.

    Let's imagine you have a function which takes three parameters, a colour, a string of text, and a filehandle. Something like this:

    sub htmlprint { my %arg = @_; $arg{file}->printf( '<span style="color:%s">%s</span>', $arg{colour}, $arg{text}, ); }

    Nice little function. Simple enough. But if people call it like this:

      htmlprint( file => $fh, text => "Hello world", color => "red" );

    ... then they'll get weird and unexpected behaviour. Have you spotted the mistake?

    Yes, "colour" versus "color".

    So it's often good to perform some kind of checking of incoming data in user-facing functions. (Private functions which aren't part of your external API might not require such rigourous checks.)

    Let's see how you might do that in Perl:

    use Carp qw(croak); sub htmlprint { my %arg = @_; exists $arg{file} or croak "Expected file"; exists $arg{text} or croak "Expected text"; exists $arg{colour} or croak "Expected colour"; $arg{file}->printf( '<span style="color:%s">%s</span>', $arg{colour}, $arg{text}, ); }

    But of course, this is only a bare minimum. We could go further and check that $arg{file} is a filehandle (or at least an object with a printf method), and that $arg{text} and $arg{colour} are strings.

    use Carp qw(croak); use Scalar::Util qw(blessed); sub htmlprint { my %arg = @_; exists $arg{file} or croak "Expected file"; exists $arg{text} or croak "Expected text"; exists $arg{colour} or croak "Expected colour"; ref($arg{file}) eq 'GLOB' or blessed($arg{file}) && $arg{file}->can('printf') or croak "File should be a filehandle or object"; defined($arg{text} && !ref($arg{text}) or croak "Text should be a string"; defined($arg{colour} && !ref($arg{colour}) or croak "Colour should be a string"; $arg{file}->printf( '<span style="color:%s">%s</span>', $arg{colour}, $arg{text}, ); }

    Suddenly our nice little function isn't looking so little any more. Type::Tiny and friends to the rescue!

    Type::Tiny comes bundled with a module called Type::Params which is designed for just this sort of thing. Let's see how it can be used.

    use feature qw(state); use Type::Params qw(compile_named); use Types::Standard qw(FileHandle HasMethods Str); sub htmlprint { state $check = compile_named( file => FileHandle | HasMethods['printf'], text => Str, colour => Str, ); my $arg = $check->(@_); $arg->{file}->printf( '<span style="color:%s">%s</span>', $arg->{colour}, $arg->{text}, ); }

    This looks a lot neater and the code is pretty self-documenting. And you can use the same type constraints you might already be using in your object attributes.

    So what's going on here? $check is a super-optimized coderef for checking the function's parameters, built using the same code inlining techniques used by Moose and Moo constructors and accessors. While it runs very fast, it is kind of slow to build it, which is why we store it in a state variable. That way it only gets compiled once when the function is first called, and can then be reused for each subsequent call.

    If you're stuck with Perl 5.8 so can't use state, then it's easy enough to do something similar with normal lexical variables:

    use Type::Params qw(compile_named); use Types::Standard qw(FileHandle HasMethods Str); my $_check_htmlprint; sub htmlprint { $_check_htmlprint ||= compile_named( file => FileHandle | HasMethods['printf'], text => Str, colour => Str, ); my $arg = $_check_htmlprint->(@_); ...; # rest of the function goes here }

    As a bonus, it actually checks more things for you than our earlier approach. In particular, it will complain if you try to pass extra unknown parameters:

    # will throw an exception because of 'size' htmlprint( file => $fh, text => "Hello world", colour => "red", size + => 7 );

    And it will allow you to call the function passing a hashref of parameters:

      htmlprint({ file => $fh, text => "Hello world", colour => "red" });

    Since Type::Tiny 1.004000 you can also supply defaults for missing parameters:

    use feature qw(state); use Type::Params 1.004000 qw(compile_named); use Types::Standard qw(FileHandle HasMethods Str); sub htmlprint { state $check = compile_named( file => FileHandle | HasMethods['printf'], text => Str, colour => Str, { default => "black" }, ); my $arg = $check->(@_); ...; # rest of the function goes here }

    Protecting Against Typos Inside the Function

    Recent versions of Type::Params allow you to return an object instead of a hashref from $check. To do this, use compile_named_oo instead of compile_named

    use feature qw(state); use Type::Params 1.004000 qw(compile_named_oo); use Types::Standard qw(FileHandle HasMethods Str); sub htmlprint { state $check = compile_named_oo( file => FileHandle | HasMethods['printf'], text => Str, colour => Str, { default => "black" }, ); my $arg = $check->(@_); $arg->file->printf( # not $arg->{file} '<span style="color:%s">%s</span>', $arg->colour, # not $arg->{colour} $arg->text, # not $arg->{text} ); }

    This will add a slight performance hit to your code (but shouldn't signiciantly impact the speed of $check) but does look a little more elegant, and will give you somewhat helpful error messages (about there being no such method as $arg->color) if you mistype a parameter name.

    Shifting off $self

    Now imagine our function is intended to be called as a method. We probably want to shift $self off @_ first. Just do this as normal:

    use feature qw(state); use Type::Params 1.004000 qw(compile_named); use Types::Standard qw(FileHandle HasMethods Str); sub htmlprint { state $check = compile_named( file => FileHandle | HasMethods['printf'], text => Str, colour => Str, { default => "black" }, ); my $self = shift; my $arg = $check->(@_); ...; # rest of the function goes here }

    It's sometimes useful to check $self is really a blessed object and not, say, the class name. (That is, check we've been called as an object method instead of a class method.)

    use feature qw(state); use Type::Params 1.004000 qw(compile_named); use Types::Standard qw(FileHandle HasMethods Str Object); sub htmlprint { state $check = compile_named( file => FileHandle | HasMethods['printf'], text => Str, colour => Str, { default => "black" }, ); my $self = Object->(shift); # will die if it's not an object my $arg = $check->(@_); ...; # rest of the function goes here }

    Positional Parameters

    For functions with three or more parameters, it usually makes sense to use named parameters (as above), but if you want to use positional parameters, use compile instead of compile_named:

    use feature qw(state); use Type::Params 1.004000 qw(compile); use Types::Standard qw(FileHandle HasMethods Str); sub htmlprint { state $check = compile( FileHandle | HasMethods['printf'], Str, Str, { default => "black" }, ); my ($file, $text, $colour) = $check->(@_); ...; # rest of the function goes here } htmlprint($fh, "Hello world", "red"); htmlprint($fh, "Hello world"); # defaults to black

    Coercions

    One of the most powerful features of Moose type constraints is type coercions. This allows you to automatically convert between types when a type check would otherwise fail. Let's define a coercion from a string filename to a filehandle:

    package My::Types { use Type::Library -base; use Type::Utils -all; use Types::Standard (); declare "FileHandle", as Types::Standard::FileHandle; coerce "FileHandle", from Types::Standard::Str, via { open(my $fh, "<", $_) or die("Could not open $_: $!"); return $fh; }; }

    Now we can use out custom FileHandle type:

    use feature qw(state); use Type::Params 1.004000 qw(compile_named); use Types::Standard qw(HasMethods Str); use My::Types qw(FileHandle); sub htmlprint { state $check = compile_named( file => FileHandle | HasMethods['printf'], text => Str, colour => Str, { default => "black" }, ); my $arg = $check->(@_); ...; # rest of the function goes here }

    Now this will work:

    htmlprint( file => "/tmp/out.html", # will be coerced to a filehandle text => "Hello world", );

    You don't need to say coerce => 1 anywhere. Coercions happen by default. If you wish to disable coercions, you can use Type::Tiny's handy no_coercions method:

    use feature qw(state); use Type::Params 1.004000 qw(compile_named); use Types::Standard qw(HasMethods Str); use My::Types qw(FileHandle); sub htmlprint { state $check = compile_named( file => FileHandle->no_coercions | HasMethods['printf'], text => Str, colour => Str, { default => "black" }, ); my $arg = $check->(@_); ...; # rest of the function goes here }

    The no_coercions method disables coercions for just that usage of the type constraint. (It does so by transparently creating a child type constraint without any coercions.)

    Performance

    All this does come at a performance cost, particularly for the first time a sub is called and $check needs to be compiled. But for a frequently called sub, Type::Params will perform favourably compared to most other solutions.

    According to my own benchmarking (though if you want to be sure, do your own benchmarking which will better cover your own use cases), Type::Params performs a smidgen faster than Params::ValidationCompiler, about five times faster than Params::Validate, about ten times faster than Data::Validator, and about twenty times faster than MooseX::Params::Validate.

    Short of writing your own checking code inline (and remember how long and ugly that started to look!), you're unlikely to find a faster way to check parameters for a frequently used sub.

    Many of Type::Tiny's built in type checks can be accellerated by installing Type::Tiny::XS and/or Ref::Util::XS.

    One very minor performance improvement... this:

      my $arg = $check->(@_);

    ... will run very slightly faster if you write it like this:

      my $arg = &{$check};

    It's a fairly Perl-4-ish way of calling subs, but it's more efficient as Perl avoids creating a new @_ array for the called function and simply passes it the caller's @_ as-is.

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 ) ; }
Install Perl module from CPAN (Apple Mac Service)
3 direct replies — Read more / Contribute
by usemodperl
on Jul 08, 2018 at 14:16
    Installing Perl modules from CPAN just got easier for Apple users.
    This service enables the following functionality in macOS/OSX:
    1. Select the name of a Perl module in any application.
    2. Select: Services -> Install Perl module from CPAN
    3. Terminal opens and CPAN client installs the module!
    This sends any selected text to the CPAN client, so it can invoke any
    command and install multiple modules, or just make a mess. The name
    of the service shown above is an option you set when saving the service.
    Use this Applescript code to create the service with Automator:

    (* Apple macOS/OSX Automator Service. *) (* Install selected Perl CPAN module! *) (* Customize the CPAN variable below: *) on run {input} set CPAN to "cpanm" try tell application "Terminal" activate tell application "System Events" to keystroke "n" using {c +ommand down} end tell tell application "System Events" tell application process "Terminal" set frontmost to true set CMD to CPAN & " " & input keystroke CMD keystroke return end tell end tell end try end run (* Source: https://perlmonks.org/?node_id=1218123 *)


    STOP REINVENTING WHEELS ⚛ START BUILDING SPACE ROCKETS!CPAN 🐪
Preaching to the camel
1 direct reply — Read more / Contribute
by usemodperl
on Jul 07, 2018 at 23:13
    One line web interface to the 3 main Perl search engines at Perldoc, CPAN and Perlmonks with 3 lovely camels! Handcrafted in quirks mode with white text on a CPAN blue background, the camel favicon and camel background are inlined from perl.com, while a big unicode camel links to Perlmonks Super Search. It writes the page to an HTML file and tries to open it in the preferred web browser of most operating systems:

    Screenshot: http://i67.tinypic.com/14a96jk.jpg

    perl -e'$u="use.perl.html";open$o,">$u"||die"$!";print$o q(<html><head +><title>#!/usr/bin/perl</title><link rel="icon" href="https://www.per +l.com/favicon.ico" type="image/x-icon"><style>body{font-family:sans-s +erif}.c{background-color:#006699;color:#FFFFFF}.a{position:absolute}< +/style><script type=text/javascript>pd="https://perldoc.perl.org/sear +ch.html";cp="https://metacpan.org/search"</script></head><body class= +c onload=document.f.q.focus()><div style="background-image:url(https: +//www.perl.com/images/site/Perl_Camel.svg);background-repeat:no-repea +t;background-size:cover;width:100%;height:100%;opacity:0.2"></div><di +v style=top:0px;left:0px;width:100% class=a><ul><h1>USE<span style=fl +oat:right><span style=top:15px;left:25% class=a><FORM name=f><input t +ype=submit value=PERLDOC class=c onclick="document.f.action=pd;docume +nt.f.submit()">&nbsp;<input name=q id=q type=text size=22 class=c>&nb +sp;<input type=submit value=CPAN class=c onclick="document.f.action=c +p;document.f.submit"></FORM></span></span></h1></div><a href=https:// +perlmonks.org/?node=Super%20Search style=text-decoration:none;font-si +ze:64px;right:6px;top:6px class=a>&#128042;&nbsp;</a><span style=font +-size:10em;bottom:15px;left:50px class=a>PERL!</span></body></html>); +close$o;$_=$^O;if(/darwin/){$x="open $u"}elsif(/m(swin|sys)/){$x=q(st +art "" "$u")}elsif(/cyg/){$x=q(cmd.exe /c start "" "$u ")}else{$x="xd +g-open $u"}system$x'


    STOP REINVENTING WHEELS ⚛ START BUILDING SPACE ROCKETS!CPAN 🐪

Add your CUFP
Title:
CUFP:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

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

    How do I use this? | Other CB clients
    Other Users?
    Others about the Monastery: (6)
    As of 2018-09-20 08:27 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      Eventually, "covfefe" will come to mean:













      Results (173 votes). Check out past polls.

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