Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
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
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 🐪
Markup::Perl Review / Demo (Basic CGI Shell)
1 direct reply — Read more / Contribute
by usemodperl
on Jul 03, 2018 at 13:13

    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.

    This 240 line demo requires the CPAN modules Markup::Perl and HTML::Entities.

    Edit: Changed URL from http:// to file:// in POD USAGE CLI.

Download favicon and convert to base64 HTML link data tag
No replies — Read more | Post response
by usemodperl
on Jul 03, 2018 at 12:33
    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.

    Single line data and output:
    perl -MHTTP::Tiny -MMIME::Base64 -e 'print qq~<link href="data:image/x +-icon;base64,~, encode_base64(HTTP::Tiny->new->get($ARGV[0])->{conten +t},""), qq~" rel="icon" type="image/x-icon">~||die"something went wro +ng"' https://perlmonks.org/favicon.ico
    Multi-line data and output:
    perl -MHTTP::Tiny -MMIME::Base64 -e 'print qq~<link href="data:image/x +-icon;base64,\n~, encode_base64(HTTP::Tiny->new->get($ARGV[0])->{cont +ent},"\n"), qq~" rel="icon" type="image/x-icon">\n~||die"something w +ent wrong"' https://www.perl.com/favicon.ico
Hopfield Neural Network in perl6
1 direct reply — Read more / Contribute
by holyghost
on Jun 29, 2018 at 22:53
    A small implementation of an Artificial Neural Network using Hopfield neurons, synapses and a simple training system :
    unit module ann; use ann::HopfieldSynaps; class HopfieldNeuron is export { has @.inputsynapses; has @.outputsynapses; has $.input; method BUILD($y1 = 1000000.rand) { $.input = $y1; } method fire() { ### with training update weights loop (my $i = 0; $i < @.inputsynapses.length; $i++) { if (@.inputsynapses[$i].weight * @.inputsynaps +es[$i].outputneuron.input >= 0) { @.inputsynapses[$i].outputneuron.input + = 1; } else { @.inputsynapses[$i].outputneuron.input + = 0; } } } }
    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; } };
    unit module ann; use ann::HopfieldNeuron; use ann::HopfieldSynaps; class HopfieldNN is export { has @.neurons; method BUILD($size) { @.neurons = (); loop (my $n = 0; $n < $size; $n++) { push (@.neurons, HopfieldNeuron.new()); } loop (my $m = 0; $m < $size; $m++) { loop (my $j = 0; $j < $size; $j++) { push(@.neurons[$j].inputsynapses, Hopf +ieldSynaps.new()); @.neurons[$j].inputsynapses[$j].output +neuron = @.neurons[$m]; } } loop (my $i = 0; $i < $size; $i++) { loop (my $j = 0; $j < $size; $j++) { push(@.neurons[$j].outputsynapses, Hop +fieldSynaps.new()); @.neurons[$j].outputsynapses[$j].outpu +tneuron = @.neurons[$i]; } } } ### repeat this to train the network method start(@inputs) { ### the inputs length is less than the full neuron lis +t ### the first neurons made in the constructor are the +inputs ### of the network loop (my $i = 0; $i < @inputs.length; $i++) { @.neurons[$i].input = @inputs[$i]; } loop (my $j = 0; $j < @.neurons.length; $j++) { @.neurons[$j].fire(); } }
    method start2(@inputs) { ### without any traning, first neurons are for the inp +ut pattern loop (my $n = 0; $n < @inputs.length; $n++) { @.neurons[$n].input = @inputs[$n]; } loop (my $i = 0; $i < @.neurons.length; $i++) { loop (my $j = 0; $j < @.neurons.length; $j++) +{ loop (my $k = 0; $k < @.neurons.length +; $k++) { if ($k == $j) { next; }; @.neurons[$i].inputsynapses[$j].weight + += (2 * @.neurons[$i].inputsynapses[$j].outputneuron.input - 1) * (2 + * @.neurons[$i].inputsynapes[$k].outputneuron.input -1); } } } } };
Tk Bandwidth use indicator
1 direct reply — Read more / Contribute
by zentara
on Jun 29, 2018 at 13:45
    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); }

    I'm not really a human, but I play one on earth. ..... an animated JAPH
Check your CPAN modules for use vars
3 direct replies — Read more / Contribute
by usemodperl
on Jun 25, 2018 at 18:37
    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"; }


    ORIGINAL:

    I heard the news today:
      Removal of use vars

      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"; }
    Output:
    
    ------------------------------------------------------------
    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 🐪
NES disassembly in perl6
1 direct reply — Read more / Contribute
by holyghost
on Jun 25, 2018 at 02:58
    NES opcodes library
    unit module dispelpotion; ### 6502 processor opcodes (Nintendo ES) class NESopcodes { has %.nesopcodes; method BUILD() { self.buildtable(); return %.nesopcodes; } method buildtable() { ### Everything is 2 bytes except where noted otherwise %.nesopcodes[0x69] = "ADC.1"; # immediate %.nesopcodes[0x65] = "ADC.2"; # zero page %.nesopcodes[0x29] = "AND.1"; # immediate %.nesopcodes[0x25] = "AND.2"; # zero page %.nesopcodes[0x0A] = "ASL.1"; # accumulator len 1 %.nesopcodes[0x06] = "ASL.2"; # zero page %.nesopcodes[0x24] = "BIT.1"; # zero page %.nesopcodes[0x2C] = "BIT.2"; # absolute len 3 %.nesopcodes[0x10] = "BPL"; # branch on plus %.nesopcodes[0x30] = "BMI"; # branch in minus %.nesopcodes[0x50] = "BVC"; # branch on overflow clear %.nesopcodes[0x70] = "BVS"; # branch on overflow set %.nesopcodes[0x90] = "BCC"; # branch on carry clear %.nesopcodes[0xB0] = "BCS"; # branch on carry set %.nesopcodes[0xD0] = "BNE"; # branch on neq %.nesopcodes[0xF0] = "BEQ"; # branch on eq %.nesopcodes[0x00] = "BRK"; # break %.nesopcodes[0xC9] = "CMP.1"; # immediate %.nesopcodes[0xC5] = "CMP.2"; # zero page %.nesopcodes[0xE0] = "CPX.1"; # immediate %.nesopcodes[0xE4] = "CPX.2"; # zero page %.nesopcodes[0xC0] = "CPY.1"; # immediate %.nesopcodes[0xC4] = "CPY.2"; # zero page %.nesopcodes[0xC6] = "DEC.1"; # immediate %.nesopcodes[0xD6] = "DEC.2"; # zero page %.nesopcodes[0x49] = "EOR.1"; # immediate %.nesopcodes[0x45] = "EOR.2"; # zero page %.nesopcodes[0x18] = "CLC"; # clear carry %.nesopcodes[0x38] = "SEC"; # set carry %.nesopcodes[0x58] = "CLI"; # clear interrupt %.nesopcodes[0x78] = "SEI"; # set interrupt %.nesopcodes[0xB8] = "CLV"; # clear overflow %.nesopcodes[0xD8] = "CLD"; # clear decimal %.nesopcodes[0xF8] = "SED"; # set decimal %.nesopcodes[0xE6] = "INC.1"; # immediate %.nesopcodes[0xF6] = "INC.2"; # zero page %.nesopcodes[0x4C] = "JMP.1"; # abs len 3 %.nesopcodes[0x6C] = "JMP.2"; # indirect len 3 %.nesopcodes[0x20] = "JSR"; # abs len 3 %.nesopcodes[0xA9] = "LDA"; # immediate %.nesopcodes[0xA5] = "LDA"; # zero page %.nesopcodes[0xA2] = "LDX"; # immediate %.nesopcodes[0xA6] = "LDX"; # zero page %.nesopcodes[0xA0] = "LDY"; # immediate %.nesopcodes[0xA4] = "LDY"; # zero page %.nesopcodes[0x4A] = "LSR.1"; # accumulator len 1 %.nesopcodes[0x46] = "LSR.2"; # zero page %.nesopcodes[0x86] = "STX.1"; # accumulator len 1 %.nesopcodes[0x96] = "STX.2"; # zero page %.nesopcodes[0x84] = "STY.1"; # accumulator len 1 %.nesopcodes[0x8C] = "STY.2"; # zero page %.nesopcodes[0x9A] = "STA.1"; # accumulator len 1 %.nesopcodes[0xBA] = "STA.2"; # zero page ### Note padding and wrap around } }
    Note that there's not switch :
    unit module dispelpotion; class Disassembler { has %.nesopcodesmap; method BUILD() { my $nesopcodes = NESopcodes.new(); %.nesopcodesmap = $nesopcodes.nesopcodes; } method disasm(@bytebuffer) { loop (my $i = 0; $i < length @bytebuffer; ) { my $opcode = %.nesopcodesmap[@bytebuffer[$i]*1 +6+@bytebuffer[$i+1]]; if ($opcode) { say $opcode + "\n"; if (not %.nesopcodesmap[@bytebuffer[$i ++2]*16+@bytebuffer[$i+3]]) { $i+=2; } if (not %.nesopcodesmap[@bytebuffer[$i ++4]*16+@bytebuffer[$i+5]]) { $i+=2; } if (not %.nesopcodesmap[@bytebuffer[$i ++6]*16+@bytebuffer[$i+7]]) { $i+=2; } $i += 2; } } } }
List EXE_FILES installed by CPAN
2 direct replies — Read more / Contribute
by usemodperl
on Jun 23, 2018 at 14:18
    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 %_;
    List EXE_FILES installed by CPAN, by module:
    #!/usr/bin/perl -l use strict; use warnings; # List EXE_FILES installed by CPAN, by module $_ = join '', `perldoc -uT perllocal`; my @m = (/=head2.*?\|([^>]+)/g); my @e = (/EXE_FILES:\s([^>]*)/sg); for (my $c = 0; $c < scalar @m; $c++) { $_{$m[$c]} = $e[$c] } my @z = (); my $n = 0; for (sort { lc($a) cmp lc($b) } keys %_) { if (my @x = split /\s+/, $_{$_}) { print; $n += scalar @x; s/^\S+\/// for @x; print " $_" for @x; print ""; } } #print $n;
    THE ORIGINAL NODE, DOES NOT WORK!:

    List EXE_FILES installed by CPAN:
    perl -le'chomp(@_=`perldoc -T perllocal`); # List EXE_FILES installed by CPAN $_=join"\n",@_;@_=split/\"Module\"\s/; @_=grep/EXE_FILES:\s[^"]+/,@_;for(@_){@x=split/\n/; @x=grep/EXE|0m/,@x;push@z,@x}s/^\s+\*\s+\"([^\"]+).?/$1/ for@z; @_=grep/EXE_FILES/,@z;@_=map{substr($_,11,length($_))}@_;undef@z; for(@_){if(/\s/){@x=split/\s/;push@z,$_ for@x}else{push@z,$_}} %_=map{s/^\S+\///;$_=>1}@z;print$_ for sort{lc($a)cmp lc($b)}keys%_'


    List EXE_FILES installed by CPAN, by module:
    perl -le'chomp(@_=`perldoc -T perllocal`); # List EXE_FILES installed by CPAN, by module $_=join"\n",@_; @_=split/\"Module\"\s/,$_; @_=grep/EXE_FILES:\s[^"]+/,@_;for(@_){@x=split/\n/; @x=grep/EXE_FILES|0m/,@x;push@z,@x}undef@x; s/^\s+\*\s+\"([^\"]+).?/$1/ for@z;my$m;for(@z){ if(/EXE_FILES:\s(.*)/){$_{$m}=$1}else{$m=$_;$_{$m}=1}} for(sort{lc($a)cmp lc($b)}keys %_){if($_{$_}=~/\s/){ @x=split/\s/,$_{$_};s/^\S+\/// for@x;$_{$_}=join"\n ", @x}else{$_{$_}=~s/^\S+\///g}print"$_\n $_{$_}\n"}'


    STOP REINVENTING WHEELS, START BUILDING SPACE ROCKETS!CPAN 🐪
Apple Perl Quine
No replies — Read more | Post response
by usemodperl
on Jun 19, 2018 at 22:09
    This perl code compiles and runs an apple mac app that decompiles and prints its own applescript source code:
    perl -Mautodie -we '$app="ApplePerlQuine\@perlmonks.org.app";die"not a +pple mac"unless${^O}eq"darwin";open$f,"|-","osacompile -o $app";print +$f qq~set myPATH to path to me as string\nset myPATH to myPATH & "Con +tents:Resources:Scripts:main.scpt"\nset myPATH to do shell script"ech +o " & myPATH & " | tr : / | sed -E \x27s/Macintosh HD//\x27"\ndisplay + dialog (do shell script ("osadecompile " & myPATH)) with title "$app +" buttons {"Use Perl!"} default button 1\n~;close$f;system("open $app +")'
Why is it so easy to make Perl apps for Apple Mac?
2 direct replies — Read more / Contribute
by Anonymous Monk
on Jun 17, 2018 at 13:40
    Compile your Perl to a portable binary application for Apple Mac (99k):
    echo 'display alert (do shell script "perl -v")' | osacompile -o perl. +app
    Write apps for Apple Mac in Perl: Pt.1, Pt.2, Pt.3
How to write apps for macOS/OSX in Perl! Part 3: Random DNS Server
No replies — Read more | Post response
by Anonymous Monk
on Jun 16, 2018 at 04:26
    Welcome to Part 3 of How to write apps for macOS/OSX in Perl! This app protects Internet Privacy by regularly changing DNS servers. It's designed to run constantly in the background. I use it all day every day for the past 2 months.

    This edition demonstrates how to:

    1. Write a very useful application!
    2. Use Perl to create, read and write a config file.
    3. Easily edit the config file.
    4. Configure multiple run time variables.
    5. Pass variables between Applescript and Perl.
    6. Handle errors and bad input.
    7. Use core Perl modules.

    See Part 1 to get started with Perl and the built-in Mac devtool Automator,
    and the demo Perl app for Mac: Perl ASN Check

    See Part 2 for more techniques to integrate Perl into Mac with Applescript,
    and the demo Perl app for Mac: Perl Version Tool

    This ~150 liner is ~120 lines of Applescript GUI logic linked to ~30 lines of core Perl code in the form of 3 one-liners! Hopefully our Mac-centric monks will pick up these techniques to write and share Mac apps to improve computing experiences with Perl! Remember: All Macs Have Perl!

      Compile this code with the instructions in Part 1
      to produce a 1.3MB portable binary application:

    Source:

    -- Set random DNS server every n minutes. # Demonstration Apple macOS/OSX app in AppleScript and Perl # Posted to perlmonks.org by Anonymous Monk 6/16/2018 # Node: How to write apps for macOS/OSX in Perl! Part 3: Random DNS Se +rver -- Part 1: Perl ASN Check https://perlmonks.org/?node_id=1216610 -- Part 2: Perl Version Tool https://perlmonks.org/?node_id=1216670 # DEFAULT DNS SERVERS: # 1.1.1.1 = Cloudflare # 8.8.8.8 = Google # 45.77.165.194 = Fourth Estate Zero Knowledge set DNS to "1.1.1.1 8.8.8.8 45.77.165.194" set DEFAULT_NETWORK to "Wi-Fi" set TITLE to "Random DNS Server" # CREATE AND/OR READ CONFIGURATION FILE: # 1. PASS APPLESCRIPT VARIABLES TO PERL -> # 2. SEND PERL VARIABLES TO APPLESCRIPT <- # 3. AND THAT LAST LINE... try set INI to do shell script "printf $HOME" & "/.dns.random.config" set CFG to do shell script " perl -Mautodie -we ' my $config = qq~" & INI & "~; if (-e $config) { open my $fh, q~<~, $config; @_ = <$fh>; close $fh; @_ = grep /\\S+/, @_; print @_; } else { open my $fh, q~>~, $config; print $fh qq~" & DNS & "~; close $fh; print qq~" & DNS & "~; } ' " on error oops display alert oops as critical end try set DNS to CFG # RUNTIME CONFIG LOOP repeat try set TXT to "DNS Servers: " & DNS & " Minutes between change? (blank to exit)" set EAE to "EXIT AND EDIT CONFIG" # GET DIALOG OBJECT CONTAINING INPUT AND CLICKED BUTTON VALUE set DUR to display dialog TXT with title TITLE default answer +"" buttons {EAE, "OK"} default button 2 set DUR_text to text returned of DUR as number set DUR_button to button returned of DUR if DUR_button is EAE then # EDIT CONFIG try do shell script "open -a TextEdit " & INI & "" return # EXIT on error oops display alert oops as critical return # EXIT end try end if if DUR_text is 0 then return # EXIT set DUR to DUR_text set NETS to do shell script "networksetup -listallnetworkservi +ces" set TXT to "Network Interfaces: " & NETS & " Network?" set NETWORK to text returned of (display dialog TXT with title + TITLE default answer DEFAULT_NETWORK buttons {"OK"} default button 1 +) try # DOES NETWORK EXIST? set hmm to do shell script " perl -we ' @_ = qx/networksetup -getinfo " & NETWORK & "/; $_ = join qq~\\n~, @_; print /Error/ ? 0 : 1; ' " on error oops display alert oops as critical return # EXIT end try if hmm as number is equal to 0 then display notification "Network not found! Exit..." with tit +le TITLE return # EXIT end if exit repeat # EXIT CONFIG LOOP on error oops display notification "This shouldn't happen!" with title TITLE return # EXIT end try end repeat # END CONFIG LOOP set MSG to button returned of (display dialog "Notification of change? +" buttons {"No", "Yes"} default button 2) # END CONFIG # MAIN EVENT LOOP repeat try # Use perl to read last line of resolv.conf as current DNS ser +ver. # Exclude current server and shuffle list to get new value. # Set new server and return the old and new values to applescr +ipt. set PERL to do shell script " perl -MList::Util=shuffle -Mautodie -we ' open my $fh, q~<~, q~/private/etc/resolv.conf~; chomp(@_ = <$fh>); close $fh; $_ = pop @_; my (undef,$cur) = split q~ ~; $_ = qq~" & DNS & "~; @_ = split /\\s+/; @_ = grep !/$cur/, @_; @_ = shuffle @_; my $new = pop @_; system(qq~networksetup -setdnsservers " & NETWORK & " +$new~); print qq~$cur $new~; ' " on error oops display alert oops as critical end try # AN APPLESCRIPT SPLIT set text item delimiters to {" "} set {CUR, NEW} to text items 1 thru 2 of PERL if MSG is "Yes" then display notification "DNS changed from " & CUR & " to " & NEW +with title TITLE end if delay ((DUR as integer) * 60) end repeat # MADE IN USA (This program, Perl, Apple, Me!) # b9ce5dcd671f9647fb86a6f3709a572ffd6e2aa490c005300585a555fabf9ce8 # 060c38ad8715a6a2381cc653ad5a7dd1815f3cf990c31594b4a1b20ef4fc9d27
How to write apps for macOS/OSX in Perl! Part 2
No replies — Read more | Post response
by Anonymous Monk
on Jun 14, 2018 at 17:00
    Welcome to Part 2 of How to write apps for macOS/OSX in Perl! See Part 1 to get started with the built-in macOS devtool Automator. This edition demonstrates how to:

    • Process choices with Perl from an Applescript dialog to:
      1. Display output from Perl to an Applescript dialog.
      2. Execute Perl in Terminal to display its output.
      3. Send output from Perl to an application (TextExit).
    Applescript is to the operating system what Javascript is the the web browser. It can do many things and what it can't do can always be handled by shell commands and especially Perl! When the code below is saved by Automator as something like PerlVersionTool.app you will have a 1.3MB portable binary application! Double click and ENJOY!
    • Other techniques covered here include:
      1. Visiting websites (Perlmonks of course!)
      2. Displaying notifications
      3. Application control
      4. Applescript subroutines
      5. Abusing buttons to widen dialogs
      6. How to rule your world with Perl!
    Source:
    (* Demonstration macOS/OSX app in AppleScript and Perl *) (* Posted to perlmonks.org by Anonymous Monk 6/14/2018 *) (* Node: How to write apps for macOS/OSX in Perl! Part 2 *) set TITLE to "Perl Version Tool" set PROMPT to "Make a selection" set _1 to "Perl version, patchlevel and license" set _2 to "Perl configuration summary" set _3 to "Perl command line help" set _4 to "Visit Perlmonks.org!" repeat set what to choose from list {_1, _2, _3, _4} with title TITLE wit +h prompt PROMPT OK button name {"View"} cancel button name {"Exit"} d +efault items _1 set what to what as string if what is _1 then set CMD to "perl -v" # ONE LINERS OR PROGRAMS OF ANY SIZE! else if what is _2 then set CMD to "perl -V" else if what is _3 then set CMD to "perl -h" else if what is _4 then display notification "Opening The Monastery Gates!" set CMD to "open https://perlmonks.org" else if what is "false" then return # EXIT end if if what is _2 then # SEND PERL CODE TO TERMINAL AND EXECUTE doShell(CMD) else if what is _3 then # CAPTURE PERL STDOUT set CMD to do shell script CMD # SEND PERL STDOUT TO TEXTEDIT textEdit(CMD) else # CAPTURE PERL STDOUT set RES to do shell script CMD # MAKE DIALOG WIDE set SPC to " + " # PRINT PERL STDOUT TO APPLESCRIPT ALERT display alert TITLE message RES buttons {SPC & "Cool" & SPC} d +efault button 1 end if end repeat # APPLESCRIPT SUBS: on doShell(CMD) 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 keystroke CMD keystroke return end tell end tell on error oops display alert oops as critical end try end doShell on textEdit(CMD) try tell application "TextEdit" activate tell application "System Events" to keystroke "n" using {c +ommand down} end tell tell application "System Events" tell application process "TextEdit" set frontmost to true keystroke CMD end tell end tell on error oops display alert oops as critical end try end textEdit
How to write apps for macOS/OSX in Perl!
3 direct replies — Read more / Contribute
by Anonymous Monk
on Jun 14, 2018 at 02:25
    macOS/OSX comes with tools that make it super easy to write native GUI applications with Applescript and Perl! This example uses the cool and free Robtex API to validate Autonomous System Numbers for networks in the global BGP table. Applescript provides plenty of ways to collect and display data, handle errors, and can launch terminals and text editors or any app and automate the entire operating system GUI while Perl does pretty much anything else you can imagine.

    Start : Applications -> Automator
    Select: File -> New
    Select: Application

    We're going to create an application but Automator can also encapsulate Perl into a Service, Image Capture Plugin, Dictation Command, Folder Action, Calendar Alarm, Print Plugin or Workflow.

    Now that Automator is open click the Library icon or select View -> Show Library.

    Select: Actions -> Utilities -> Run AppleScript (double click it)

    Replace the default code with this:

    (* Demonstration MacOS/OSX app in AppleScript and Perl *) (* Posted at perlmonks.org by Anonymous Monk 6/13/2018 *) (* Node: How to write apps for macOS/OSX in Perl! *) repeat repeat try set ASN to text returned of (display dialog "Autonomous Sy +stem Number: (Example: 714 is Apple Inc. 666 does not exist. Blank to exit.)" with +title "Perl ASN Check" default answer "" buttons {"Check"} default bu +tton 1) set ASN to ASN as number # require a number exit repeat # continue if ASN is numeric on error # not a number? display alert "Please enter an Autonomous System Number!" +as critical end try end repeat if ASN is equal to 0 then return # exit if blank # ALL MACS HAVE PERL BABY! set RES to do shell script " perl -MHTTP::Tiny -e ' my $r = HTTP::Tiny->new->get(q~https://freeapi.robtex.com/ +asquery/" & ASN & "~); if (length $r->{content}) { $r->{content} =~ /[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+/ ? print q~ASN Exists!~ : print q~ASN Not Found!~; } else { print q~Download failed!~ } ' " display alert RES end repeat

    Save the application and double click its icon in finder. BEHOLD! Perl apps for macOS/OSX!!!

    (Tips: In the Perl code avoid single quotes and be prepared to do some extra backslashing.)


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 all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others perusing the Monastery: (5)
    As of 2018-07-21 08:05 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      It has been suggested to rename Perl 6 in order to boost its marketing potential. Which name would you prefer?















      Results (445 votes). Check out past polls.

      Notices?