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)) {
...;
}
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).
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
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);
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.
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:
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],
);
}
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;
}
}
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},
);
}
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 );
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
}
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
}
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
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;
};
}
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
}
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.
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 ;
#!/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 ) ;
}
Installing Perl modules from CPAN just got easier for Apple users.
This service enables the following functionality in macOS/OSX:
Select the name of a Perl module in any application.
Select: Services -> Install Perl module from CPAN
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 *)
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:
There are many ways to embed Perl in HTML. One of my
favorites that gets something in a browser rapidly is
the module Markup::Perl. Once imported with "use"
the script behaves like an HTML document with an
excellent new <perl> tag that enables perl embeds!
It automatically imports param, cookie and header
functions from the CGI distribution to handle input,
memory, and output tasks. It can also recursively
include files with more <perl> tags.
Markup::Perl has been around since 2006
with only 1 revision. The module code is miniscule and
powerful. The documentation is brief yet complete. Super
Search can't find any mention of it in The Monastery so
it must be time for a review! 12 years after release this
remains a mature and stable distribution.
One-liner fetches favicon from the network,
converts it to base64, and prints an HTML link tag with
favicon data URL. Use with discretion, favicons may be
legally possessed. It's great fun to jazz local
scripts and documents.
unit module ann;
use ann::HopfieldNeuron;
class HopfieldSynaps is export {
has $.weight;
has $.inputneuron;
has $.outputneuron;
method BUILD($inputneuron, $outputneuron, $y1 = 1000000.rand)
+{
$.weight = $y1;
}
};
Hi, I was looking for a simple program to display my bandwidth usage. I tried many c programs, nload, nethogs, etc, but to my dismay they often jumped to 100% cpu usage, and more often than not, they needed root priviledges to run. Ugh. So I found a bash shell script which is floating around on the search engines which did the trick. The problem with it, was that it was a scrolling display in an xterm, and I always had to set the Window Manager option on the xterm to "Stay on Top". It was a hassle plus it didn't look sweet. So I put the basic idea from the shell script into a Tk script, and I have something useful enough to post here. :-)
You set your interface to watch on the command line, as first argument, or it defaults to eth0. I placed it just above the lower right corner to stay out of most things way. Once the display is started, a left mouse button click on it kills it.
It also has a non-blocking sleep (thx to Slaven Reszic) that you might find useful in other Tk scripts.
#!/usr/bin/perl
use warnings;
use strict;
use Tk;
#specify interface on commandline or here
my $iface = shift || 'eth0'; #correction
my $mw = new MainWindow;
# I have my toolbar at the top, so
# I like my info boxes at the bottom
$mw->geometry('-50-50');
$mw->overrideredirect(1);
$mw->configure(-cursor => 'pirate'); #:-)
$mw->fontCreate('big',
-family=>'courier',
-weight=>'bold',
-size=> 18);
my $bw = $mw->Label(-text=>' ',
-font=>'big',
-bg=>'black', -fg=>'yellow')->pack
(-side=>'left',-fill =>'both');
# left click exits program
$mw->bind('<1>' => sub{exit});
#refresh every 1.5 seconds
my $id = Tk::After->new($mw,1500,'repeat',\&refresh);
MainLoop;
sub refresh{
my $r0 = `cat /sys/class/net/$iface/statistics/rx_bytes`;
my $t0 = `cat /sys/class/net/$iface/statistics/tx_bytes`;
tksleep($mw, 1000);
my $r1 = `cat /sys/class/net/$iface/statistics/rx_bytes`;
my $t1 = `cat /sys/class/net/$iface/statistics/tx_bytes`;
my $rr = sprintf ("%03d",($r1 - $r0)/1024);
my $tr = sprintf ("%03d",($t1 - $t0)/1024);
$bw->configure(-text=>"Rx: $rr kBs || Tx: $tr kBs");
}
sub tksleep {
# Like sleep, but actually allows the display to be
# updated, and takes milliseconds instead of seconds.
# A non-blocking sleep for the eventloop
my $mw = shift;
my $ms = shift;
my $flag = 0;
$mw->after($ms, sub { $flag++ });
$mw->waitVariable(\$flag);
}
Edit: Since no one likes my joke about use vars this node has been amended to a more useful version of the program:
#!/usr/bin/perl ##################################
# Check installed *CPAN* modules for COMMENTS! #
# Because CPAN modules have a lot of COMMENTS! #
# https://perlmonks.org/index.pl?node_id=1217408 #
##################################################
use strict;
use warnings;
use Config '%Config';
use ExtUtils::Installed;
for (split $Config{path_sep}, $ENV{PATH}) {
$|++ if -x "$_/grep"
}
die "you need grep" unless $|;
my $time = time;
my $perl = ExtUtils::Installed->new;
my @cpan = $perl->modules();
my @temp = ();
for (@cpan) {
my @cpan = $perl->files($_);
push @temp, @cpan;
}
@cpan = grep /site.*\.pm$/, @temp;
my $opt = 0;
if (@ARGV) { $opt = 1 }
else {
print qq~Checking CPAN modules for COMMENTS in Perl versio~.
qq~n $^V\n(Invoke with any arg to skip questions and gener~.
qq~ate a list of modules.)\n\n~;
print qq~The list may be big and printing progress makes i~.
qq~t a bit slower.\nDefault: display progress, format outp~.
qq~ut and print offending lines of code.\nPress return to ~.
qq~start or n for no progress and list output. y/N~;
chomp($opt = <STDIN>); $opt = 1 if $opt and lc $opt eq 'n';
}
my $INC = join '|', @INC;
my $acme = 0;
my $grep = 0;
for my $cpan (@cpan) {
print "\rChecking: ","$acme\tFound: $grep\t" unless $opt;
if(@_ =`grep '^#' $cpan`) {
@_ = grep !/^#(pod|[\-=~\*]|[#]{5,}|\s*\n)/,@_; # FAKE
next unless scalar @_;
(my $name = $cpan) =~ s/($INC)//;
$name =~ s,^/,,;
$name =~ s,/,::,g;
$name =~ s/\.pm$//;
s/^\s+/ / for @_;
$_{$name} = join "\n ", @_;
$grep++
}
$acme++
}
if ($opt) {
print "$_\n" for sort keys %_
}
else {
$perl = scalar keys %_;
$time = time - $time;
print qq~$perl CPAN modules (out of $acme) found with COMMENTS!\n~;
print "$_:\n $_{$_}","-"x60,"\n" for sort keys %_;
print qq~$perl CPAN modules (out of $acme) found with COMMENTS!\n~;
print "That took $time secs (grep searched ",sprintf("%0d",$perl/$t
+ime),
" modules/sec).\n";
}
The usage of use vars has been discouraged since the introduction of our in Perl 5.6.0. Where possible the usage of this pragma has now been removed from the Perl source code.
And had to find out how many modules are afflicted on my system (5.26.2):
905 CPAN modules (out of 4918) found with "use vars"!
Code for you:
#!/usr/bin/perl ######################################
# Check installed CPAN modules for use of "use vars" #
# Because Perl 5.28.0 removes discouraged "use vars" #
# https://perlmonks.org/index.pl?node_id=1217408 #
######################################################
use strict;
use warnings;
use autodie;
use Config '%Config';
use ExtUtils::Installed;
for (split $Config{path_sep}, $ENV{PATH}) {
$|++ if -x "$_/grep"
}
die "you need grep" unless $|;
my $t = time;
my $m = ExtUtils::Installed->new;
my @temp = $m->modules();
my @cpan = ();
for (@temp) {
my @x = $m->files($_);
push @cpan, @x;
}
@cpan = grep /site.*\.pm$/, @cpan;
my $opt = 0;
if (@ARGV) { $opt = 1 }
else {
print qq~Checking CPAN modules for "use vars" in Perl version $^V ~.
qq~(removed in Perl 5.28)\nhttps://metacpan.org/pod/release/XSAWYE~.
qq~RX/perl-5.28.0/pod/perldelta.pod#Removal-of-use-vars \n(Invoke~.
qq~ with any arg to skip questions and generate a list of modules.) \n
+\n~;
print qq~The list may be big and printing progress makes it a bit slow
+er.
Default: display progress, format output and print offending lines of
code. Press return to start or n for no progress and list output. y/N~
+;
chomp($opt = <STDIN>); $opt = 1 if $opt and lc $opt eq 'n';
}
my $INC = join '|', @INC;
my $n = 0;
my $g = 0;
for my $c (@cpan) {
print "\rChecking: ","$n\tFound: $g\t" unless $opt;
if (@_ = `grep 'use vars' $c`) {
(my $f = $c) =~ s/($INC)//;
$f =~ s,^/,,;
$f =~ s,/,::,g;
$f =~ s/\.pm$//;
s/^\s+/ / for @_;
$_{$f}=join"\n ",@_;
$g++
}
$n++
}
if ($opt) {
print "$_\n" for sort keys %_
}
else {
$m = scalar keys %_;
$t = time - $t;
print qq~$m CPAN modules (out of $n) found with "use vars"!\n~;
print "$_:\n $_{$_}","-"x60,"\n" for sort keys %_;
print qq~$m CPAN modules (out of $n) found with "use vars"!\n~;
print "That took $t secs (grep searched ",sprintf("%0d",$m/$t),
" modules/second).\n";
}
------------------------------------------------------------
XML::Twig:
use vars qw($VERSION @ISA %valid_option);
use vars qw( $weakrefs);
use vars qw( %filter);
------------------------------------------------------------
XML::Twig::XPath:
use vars qw($VERSION);
------------------------------------------------------------
YAPE::Regex:
use vars '$VERSION';
------------------------------------------------------------
YAPE::Regex::Explain:
use vars '$VERSION';
------------------------------------------------------------
905 CPAN modules (out of 4918) found with "use vars"!
That took 31 secs (grep searched 29 modules/second).
STOP REINVENTING WHEELS, START BUILDING SPACE ROCKETS!—CPAN 🐪
EDIT: The original node was buggy so here's a fixed version that seems to show all the executables installed by CPAN! Original node below so I can be embarrassed forever.☺
List EXE_FILES installed by CPAN:
#!/usr/bin/perl -l
use strict;
use warnings;
# List EXE_FILES installed by CPAN
$_ = join '', `perldoc -uT perllocal`;
@_ = (/EXE_FILES:\s([^>]+)/sg);
my @z = ();
for (@_) {
my @x = split /\s+/;
s/^\S+\/// for @x;
push @z, @x;
}
%_ = map { $_ => 1 } @z;
print $_ for sort keys %_;
#print scalar keys %_;
