App-Cheats
view release on metacpan or search on metacpan
my $help = <<~"HELP";
# Search for specific keywords in cheats or notes.
<SCRIPT> 'KEYWORD'
<SCRIPT> 'KEYWORD' 'KEYWORD'
# Options:
$options
HELP
say _colored( $help );
exit;
}
sub _colored {
my ( $msg ) = @_;
package My { use Mojo::Base -base };
my $my = My->with_roles( "+ColoredHelp" )->new;
$my->color_msg( $msg, basename( $0 ) );
if(not @cheat_files){
my $help = <<~HELP;
No cheat files found!
Refer to:
perldoc App::Cheats
HELP
say colored($help, "RED");
exit 1;
}
for my $path ( @cheat_files ) {
my $file = basename( $path );
open my $fh, "<", $path or die "Error with file '$path': $!";
while ( <$fh> ) {
next if not /\S/;
chomp;
# Change the title of the command prompt window
title MY_TITLE
# Change the dimentions/size of a commmand prompt window (length,width)
mode con: cols=80 lines=10
# Temporarily chang ethe command prompt language to english
set LANG=US
# Enable ANSI colors in Windows 10 using system '' (magic!?)
perl -E "system ''; say qq(\033[35mHEY\033[0m)"
# Terminator config location
/home/tim/my/git/otrs/SETUP/terminator/config
#############################################################
## Bison/Flex Parsing (Regex)
#############################################################
# Good tutorial
docker start -a -i 99150a04a616
# Run interactive container (bash shell)
docker run -it perl bash
# Go inside a running container.
docker container exec -it feedback-app bash
# Build updated perl image.
docker build -t my-perl .
docker run my-perl -E 'say $^V'
# Rename a docker container
docker container rename <CONTAINER_ID> my-perl-container
# Restart a container
docker container start -a my-perl-container
#############################################################
## Docker Dockerfile Commands
#############################################################
# Dockerfile commands:
# These are executed only during a BUILD.
FROM perl
WORKDIR /app
COPY . /app
RUN echo "Building the image now"
RUN perl -E 'say "Image uses perl version: $^V"'
# Dockerfile commands:
# These are executed only during a RUN.
CMD [ "ls" ]
CMD [ "echo", "Run the container now" ]
CMD [ "perl", "my.pl" ]
#
ENTRYPOINT [ "perl" ]
docker run <IMAGE_ID> -E 'say $^V'
# Dockerfile commands:
# COPY can be controlled by
cat .dockerignore
.git*
node_modules
#############################################################
## Docker Images/Containers
#############################################################
# Images and containers.
# Image - blueprint.
# Container - instance of image.
# Get an image with perl inside.
docker run perl perl -E 'say $^V'
#
# Or in 2 steps.
docker pull perl
docker images
docker run <IMAGE_ID> perl -E 'say $^V'
docker run -it perl:5.38-slim perl -E 'say 123'
# Dump the contents of an image.
docker image inspect my-perl
# Copy file to/from a container.
# For config files.
docker cp youthful_brown:/app/.bashrc .
# Assign tag to an image
docker build -t REPO:TAG .
#############################################################
## Docker Images/Containers - Cleanup
#############################################################
# Remove all stoped containers.
docker container prune
# Auto remove container on exit
docker run --rm <IMAGE_ID> perl -E 'say $^V'
# Remove all docker containers and images.
docker rm --force $(docker ps -aq)
docker rmi --force $(docker images -aq)
# Remove stuck containers
sudo systemctl stop docker.service
sudo su
rm -f /var/lib/docker/containers/* # just "sudo ..." doesnt work for some reason.
exit
# Upload to dockerhub.
# Make sure repo is public or you cant upload due to restrictions.
docker push poti1/my-perl-server:latest
# Fetch image.
docker pull poti1/my-perl # Always fetches the latest.
docker run poti1/my-perl # Fetches only if missing locally.
# Use an uploaded image.
docker run -it --rm poti1/my-perl -E 'say 123'
#############################################################
## Docker Data/Volumes
#############################################################
# 2 types of volumes/mount
# -v LOCAL:DOCKER:PERMISSIONS
docker run -v /app/data # Anynymous volume.
docker run -v data:/app/data # Named volume.
#############################################################
## Docker ARG/ENV
#############################################################
# Using environmental variables in a Dockerfile.
ENV PORT 80
EXPOSE $PORT
# Build and run using an environmental variable
docker run --env DEBUG=1
docker run --rm --env PORT=8000 poti1/my-perl -E 'say "123 $ENV{PORT}"'
# Provide arguments when building a docker image.
ARG DEFAULT_PORT=8080
ENV PORT $DEFAULT_PORT
EXPOSE $PORT
docker build --build-arg DEFAULT_PORT=3000
#############################################################
## Docker Networking
# Docker Kubernetes - Definitions.
minikube - Can be used to simular other machines.
Does not replace kubectl.
# Docker Kubernetes - Pod Object.
# Docker Kubernetes - Deployment Object.
Controls (multiple) pods.
Can set desired state.
Define which pods to run and how many.
Pause, delete, roll back deployments (say for a bug fix).
Scalable.
Used often instead of directly controlling pods.
#############################################################
## Docker Kubernetes - Usage (Imperative Approach)
#############################################################
# Docker Kubernetes - Simple App Example
cd ~/my/git/otrs/docker/learning_docker/12-Kubernetes/kub-action-01-starting-setup
crontab
cron
at
# Crontab job in interactive mode
* * * * * DISPLAY=localhost:11.0 xterm -e 'read -p "aaa - 3"'
# crontab job sent to any particular IP address
* * * * * DISPLAY=1.1.1.1:0 xterm -e 'read -p "aaa - 3"'
# Run a task according to a step amount (say every 5 minutes, crontab)
# min hr dom mon dow command
/5 * * * * my_command
# Run crontab at 3am and 3pm (task)
# min hr dom mon dow command
* 3,15 * * * my_command
#############################################################
## Linux Commands - curl
showpath | xargs ls -ld 3>&2 2>&1 1>&3
# Redirect STDERR to STDOUT
showpath | xargs ls -ld 2>&1 1>/dev/null
# Show only STDERR (redirect STDOUT)
ld_dsu.prl sre csv |1
ld_dsu.prl sre csv 1>/dev/null
# Send message to STDERR
say(){ echo "GOOD"; echo "BAD" >&2; }
say 2>/dev/null # GOOD
say >/dev/null # BAD
say >> log 2>&1
say 2>&1 >> log
#############################################################
## Bash Signal Handling
#############################################################
# Use trap command to trap signals
trap arg signals
# Remove signal handling
---
LEFT-TO-RIGHT OVERRIDE (U+202D)
Forces text to be displayed left-to-right, overriding the
surrounding context.
---
RIGHT-TO-LEFT OVERRIDE (U+202E)
Forces text to be displayed right-to-left, overriding the
surrounding context.
# zero-width Unicode characters example.
perl -C -E 'say "<!START_\N{ZERO WIDTH SPACE}A\N{LEFT-TO-RIGHT MARK}B\N{RIGHT-TO-LEFT MARK}C\N{ZERO WIDTH NON-JOINER}-->"'
# Output:
<!START_​A‎Bâ€C‌-->
# Zero-width example of hiding text in a text area (plain text,POC)
perl -C -Me -E 'sub _BuildMark{ unpack("B*", "<!$_[0]-->") =~ tr/01/\N{ZERO WIDTH SPACE}\N{LEFT-TO-RIGHT MARK}/r } my $B = join "", _BuildMark("START_ABC"), "Line1: Ok\nLine2: NOk", _BuildMark("END_ABC"); say $B; d $B'
Line1: Ok
Line2: NOk
# Zero-width example of hiding text in a text area (plain text, POC, WIP)
perl -C -Me -E 'sub _BuildMark{ unpack("B*", "<!$_[0]-->") =~ tr/01/\N{ZERO WIDTH SPACE}\N{LEFT-TO-RIGHT MARK}/r } sub _ContainsMark { index(shift, _BuildMark(shift)) != -1 } $_ = join "", "Before\n", _BuildMark("START_ABC"), "Line1: Ok\nLine2: NOk",...
#############################################################
## HTML - Validation
#############################################################
# Input element validation in html (check,regex)
<input name="NAME" type="number" placeholder="?" step="any" class="value" style="grid-column: 5 / 6; grid-row: 2 / 3;" value="4.000">
<input name="name" type="text" pattern="^[-\wÄäÖöÜü\.,_]+$" value="VALUE">
@echo
#############################################################
## Make Command Line Arguments
#############################################################
# Processing command line arguments in a makefile
tm_all:
@echo "All inputs:"
@perl -E 'say "[$$_]" for @ARGV;' $(MAKECMDGOALS)
@echo ---
@echo "All target arguments:"
@perl -E 'say "[$$_]" for @ARGV;' $@
@echo ---
@echo "All non target arguments:"
@perl -E 'say "[$$_]" for @ARGV;' $(filter-out $@,$(MAKECMDGOALS))
#############################################################
## MySQL
#############################################################
# Install MySQL on linux.
sudo apt install mysql-server mysql-client libmysqlclient-dev
sudo systemctl start mysql.service
mysql -u root
- The quality that makes you go to great effort to reduce overall energy expenditure.
- It makes you write labor-saving programs that other people will find useful and
- document what you wrote so you don't have to answer so many questions about it.
- Impatience:
- The anger you feel when the computer is being lazy.
- This makes you write programs that don't just react to your needs,
- but actually anticipate them.
- Or at least pretend to.
- Hubris:
- The quality that makes you write (and maintain) programs that other
- people won't want to say bad things about.
# Create a modulino (Module/program that can be also run standalone/by itself)
run unless caller;
# Use yadda yadda to denote not yet implemented code.
perl -E 'sub F{} F'
perl -E 'sub F{...} F'
Unimplemented at -e line 1.
+ my $col = $_;
+ max map {
+ length $_[$_][$col];
+ } 0 .. $last_row;
+ } 0 .. $last_column;
+
+ \@max;
+ }
# Iterate through index and value of an array.
perl -E '@arr = qw( a b c ); say "[$i] $v" while ($i,$v) = each @arr'
[0] a
[1] b
[2] c
# Rand from 10-15
perl -Me -E 'my @n = sort map { int rand( 6 ) + 10 } 1..100; say for c(@n)->uniq->each'
# Loop through a list of items while processing 3 at a time.
perl -E 'for my ($x,$y,$z) ( 1..50 ) { say "$x-$y-$z" }'
for my (...) is experimental at -e line 1.
1-2-3
4-5-6
7-8-9
10-11-12
13-14-15
16-17-18
19-20-21
22-23-24
25-26-27
# Convert to binary using recursion (POC,perl).
sub binary{
my($n) = @_;
$n //= $_;
return $n if $n == 0 or $n == 1;
my $k = int($n/2);
my $b = $n % 2;
binary($k) . $b;
}
for(1..40){
say "$_ ", binary;
}
__END__
1 1
2 10
3 11
4 100
5 101
6 110
7 111
8 1000
# Global our must be used within regex embedded code (bug)
# Appears to only be a problem in older versions of Perl
perl -le 'sub func{my($t)=@_; my $s; my $m = $t =~ m{ (?{ $s //= $-[0] }) \d}x; print "t=[$t]\ns=[$s]\nm=[$m]\n"} func 1; func 1'
perl -le 'sub func{my($t)=@_; our $s; my $m = $t =~ m{ (?{ $s //= $-[0] }) \d}x; print "t=[$t]\ns=[$s]\nm=[$m]\n"} func 1; func 1'
# Segmentation fault in perl on some systems (Gentoo,SEGV)
# https://github.com/Perl/perl5/issues/19147
perl -we '$a{$b}'
# Run script multiple times in order and stop on the first error.
for n in {1..1000}; do perl -I. -IKernel/cpan-lib -MSchedule::Cron::Events -E 'eval{ Schedule::Cron::Events->new("* * 0 * *", Date => [ 16, 25, 16, 10, 7, 123])}; say "OK"'; if [ $? -ne 0 ]; then echo "STOPPED on run: $n"; break; fi; done
# Perl SEGV due to confess
https://github.com/Perl/perl5/issues/15928
# Variable suicide bug (fixed pre v5.6)
https://perldoc.perl.org/perlfaq7#What-is-variable-suicide-and-how-can-I-prevent-it?
perl -E 'my $f = 'foo'; sub func { while ($i++ < 3) { my $f = $f; $f .= "bar"; say $f }} func; say "Finally $f\n"' foobar foobar
foobar
Finally foo
# Perl lexical variable eval bug (fixed after 5.40).
https://www.perlmonks.org/?node_id=11158351
https://github.com/Perl/perl5/pull/22097
# Refresh a Module (bug):
https://www.perlmonks.org/?node_id=11161935
str => "some error name",
type => "bad",
level => 2,
};
};
p $@;
# Can use $^S to check if inside of an eval block.
# eval State.
perl -E '
sub f { say $^S }
f;
eval { f };
eval "f";
'
0
1
1
#############################################################
DO NOT REMOVE THE PRECEDING LINE.
#############################################################
## Perl File Syntax
#############################################################
# Can use "#" as a line number directives. (Perl File Syntax)
# https://perldoc.perl.org/perlsyn#Plain-Old-Comments-(Not!)
# Note: It marks the NEXT line.
perl -E 'eval qq(# line 123 myfile.txt\ndie "My bad"); say $@'
My bad at myfile.txt line 123.
# Perl File Syntax
# When opened for reading, the special
# filename “–†refers to STDIN. When
# opened for writing, the same special
# filename refers to STDOUT.
# Normally, these are specified as “<–†and “>–â€,
# respectively.
open(INPUT, "–" ) || die; # re–open standard input for reading
perl -le 'push @ARGV, map /\S+/g,<STDIN> unless -t; print "[$_]" for @ARGV'
perl -le 'print -t() ? "RIGHT" : "LEFT"'
echo | perl -le 'print -t() ? "RIGHT" : "LEFT"'
#############################################################
## Perl Golf - General
#############################################################
# Get the Path variable on DOS
path | perl -E "$/=';'; say for <>"
path | perl -073 -nE "say"
path | perl -073 -l12 -pe ""
path | perl -073l12 -pe ""
path | perl -073l12pe ""
path | perl -073l12pe0
path | perl -lp073e0
# Get the Path variable on Linux
path | perl -073 -nE "say"
echo "$PATH" | perl -E '$/=":"; say for <>'
echo "$PATH" | perl -072 -nE 'say'
echo "$PATH" | perl -072 -l12 -pe ''
echo "$PATH" | perl -072l12 -pe ''
echo "$PATH" | perl -072l12pe ''
echo "$PATH" | perl -072l12pe0
echo "$PATH" | perl -lp072e0
#############################################################
## Perl Golf - Column Selection
# Print a file in reverse order like tac (golf)
cat alpha.txt | perl -pe '$\=$_.$\}{'
#############################################################
## Perl Hash
#############################################################
# Get size of a hash.
perl -E '%h = qw( cat 11 bat 22 mat 33 ); say ~~ keys %h; say ~~ %h'
3
3
# Process a hash/array with a queue instead of a recursive approach.
# Using for loop.
perl -Me -e 'my @queue; my @arr = ( 4,5,6); for my $val ( @arr ) { push @queue, \$val }; $$_ += 3 for @queue; p \@arr'
perl -Me -e 'my @q; my %h = ( a => 1 ); for my $k ( keys %h ) { push @q, \$h{$k} }; $$_ += 3 for @q; p \%h; p \@q'
#
# Using map and $_ works also :)
perl -Me -e 'my @q; my @a = ( 4,5,6); push @q, map { ref() ? $_ : \$_ } @a; $$_ += 3 for @q; p \@a'
# This is documented in:
perldoc -f values
"""
Note that the values are not copied, which means modifying them
will modify the contents of the hash:
for (values %hash) { s/foo/bar/g } # modifies %hash values
for (@hash{keys %hash}) { s/foo/bar/g } # same
"""
# Values and map return aliases to the real data.
perl -Me -e 'my %h = ( a => 111 ); say \$h{a}; say for map { \$_ } values %h'
SCALAR(0xb4000073dec1f678)
SCALAR(0xb4000073dec1f678)
# Values and map return aliases to the real data.
perl -Me -e 'my @a = ( 111, 222 ); say \$a[0]; say \$a[1]; say for map { \$_ } @a; say for \( @a )'
SCALAR(0xb4000073a2e1f678)
SCALAR(0xb4000073a2e1f840)
SCALAR(0xb4000073a2e1f678)
SCALAR(0xb4000073a2e1f840)
SCALAR(0xb4000073a2e1f678)
SCALAR(0xb4000073a2e1f840)
# Process a hash/array with a queue instead of a recursive approach.
# This is documented in:
perldoc -f map
perl -wE '
$_ = "0 but true";
printf "numeric=%d, bool=%s string=%s\n",
0+$_,
!!$_,
"".$_;
'
numeric=0, bool=1 string=0 but true
# Special string to represent infinity.
perl -E 'say "nan" == "nan"' # false
perl -E 'say "nan" eq "nan"' # true
perl -E 'say "Inf" + 1'
# Inf and Infinity are similar.
perl -E 'say "Inf" == "Inf"' # 1
perl -E 'say "Inf" == "Infinity"' # 1
perl -E 'say "Infinity" == "Infinity"' # 1
# v5.32 allows chaines comparisons.
# The comparison variable is evaluated only once.
perl -E 'say 1 < 2 < 3 < 4' # 1
perl -E 'say 1 < 2 < 3 == 4' # ""
# Can use eval in perl for doing basic arithmetic (math)
for(qw (+ - * /)){
my $exp = "3 $_ 3";
my $ans = eval "$exp";
print "$exp = $ans\n";
}
# In perl to get the log of another base,
# use basic algebra: the base-N log
sub log_base {
my ($base, $value) = @_;
return log($value)/log($base);
}
# Calculate GCD and LCM using euclids formula.
perl -E '
$_m = $m = 35;
$_n = $n = 20;
while ( 1 ) {
say "$m, $n, ", ($_m * $_n / $m);
last if !$n;
($m,$n) = ($n, $m % $n);
}
'
35, 20, 20
20, 15, 35
15, 5, 46.6666666666667
5, 0, 140
# Factorial recursive.
perl -E 'sub factorial { my ($n) = @_; return 1 if $n <= 1; $n * factorial($n-1) } say factorial(4)'
24
# Factorial non-recursive.
perl -E 'sub factorial { my ($n) = @_; my $f = 1; $f *= $_ for 1..$n; $f } say factorial(4)'
24
perl -E 'sub factorial { my ($n) = @_; my $f = 1; $f *= $n-- while $n > 1; $f } say factorial(4)'
24
#############################################################
## Perl Math - Trigonometry
#############################################################
# Generate a sine/cosine wave.
perl -E 'my $i=0; while(1) { my $sin = sin $i; my $cos = cos $i; my @spots = map { int($_*20+20) } $sin, $cos; my $dots = " " x 40; substr $dots, $_, 1, "." for @spots; say "$dots [$i] @spots"; $i+=0.25; last if $i > 100 }'
. . [0] 20 40
. . [0.25] 24 39
. . [0.5] 29 37
.. [0.75] 33 34
. . [1] 36 30
. . [1.25] 38 26
. . [1.5] 39 21
. . [1.75] 39 16
. . [2] 38 11
. . [2.25] 35 7
perl -le '@mem=(65,66,67); print for pack "C*",@mem'
# Unpack a string into its ordinal values
perl -le '$mem="ABC"; print for unpack "C*",$mem'
# Data selection. alternative to substr. Use to column splitting when spaces do not necessary delimit
perl -le '($what,$where,$howmuch)=@ARGV; print unpack "x$where A$howmuch", $what' "[abc def][hij][klm]" 1 7
# sprintf versus pack, unpack.
# These are same.
perl -E 'say for unpack "H*", pack "C*", 100'
perl -E 'printf "%x\n", 100'
64
#############################################################
## Perl PAUSE Account
#############################################################
# Upload to pause server without a browser.
# 1. Need to file create a .pause file
# Perl regex optimization is supressed (with either character class or Dynamic Regex Construct)
echo "line1 Liine2" | perl -nle '$r=qr[(?s-xim:line1(?{print"got line1\n"}).*?[Ll]ine2(?{print"got line2\n"}))]; /$r/'
echo "line1 Liine2" | perl -nle '$r=qr[(?s-xim:line1(?{print"got line1\n"}).*?(??{line2})(?{print"got line2\n"}))]; /$r/'
# Global match in JavaScript, but all return all captures. /(.*?)/g
regex = /<script[^>]*>(?<s>.*?)<\/script>/g
str = "blah<script>111</script><script>222</script><script>333</script>blah2"
while(my = regex.exec(str)){ console.log(my[1]) }
# Remove control characters
perl -E '$c = "\e[31mHERE\e[0m"; $c =~ s&\p{PosixCntrl}&*&g; say $c'
# \p{PosixCntrl} - ASCII-range Unicode.
# \p{XPosixCntrl} - Full-range Unicode.
# Named captures affect %+ and %+, but ALSO $1,$2
perl -Mojo -E '"abc" =~ /(?<first>.)(?<second>.)(?<third>.)/; say r \%-; say r \%+; say "1:$1"; say "2:$2"; say "3:$3"'
# Using /a flag to limit to ascii.
perl -C -E 'say "\N{BENGALI DIGIT FOUR}"' # ৪
perl -C -E 'say "\N{BENGALI DIGIT FOUR}" =~ /\d/' # 1
perl -C -E 'say "\N{BENGALI DIGIT FOUR}" =~ /\d/a' # ""
perl -C -E 'say 0+"\N{BENGALI DIGIT FOUR}"' # 0
# CAUTION: regex variables get reset on the next successful match.
perl -E '"abc" =~ /(.*)/; say "[$1]"; 123 =~ /1/; say "[$1]"'
[abc]
[]
#
# Also a function passes in its variables by reference.
# @_ is an alias to the arguments.
perl -E 'sub f { $_[0] = "new" } my $v = "old"; f($v); say $v'
new
#
# This can lead to input suddenly disappearing
# or changing when using unquoted regex variables.
perl -E 'sub f{ say "f(@_)" } "abc" =~ /(.*)/; f($1)'
F1(abc) # Bad, but still works.
perl -E 'sub f{ 123 =~ /1/; say "F1(@_)" } "abc" =~ /(.*)/; f($1)'
F1() # BAD, $1 gets changed.
perl -E 'sub f{ 123 =~ /1/; say "f(@_)" } "abc" =~ /(.*)/; f("$1")'
f(abc) # Correct way: quote "$1"
#############################################################
## Perl Regular Expressions - Best Practices
#############################################################
# Perl Regular Expressions - Best Practices
# No free lunch
# Optimizations often result in a savings, but not
# and importantly, how likely it is to be invoked.
# Perl Regular Expressions - Best Practices
# Say what you mean
# The problem is that the first.+" matches past
# the backslash, pulling it out from under the
# (\\ \n.+)+" that we want it to be matched by.
#
# Well, here’s the first lesson of the chapter:
# if we don’t want to match past the backslash,
# we should say that in the regex.
#
# We can do this by changing each dot to:
[ˆ\n \\].
#############################################################
## Perl Regular Expressions - Bugs
#############################################################
# Perl Regular Expressions - Bugs
# // means to mast the last successive pattern.
# If none, then would match empty.
# Explicitly use /(?:)/ for empty instead.
# https://perldoc.perl.org/perlop#The-empty-pattern-//
#
# Avoid using single variable directly in regex (like $want below):
perl -E '$want = ""; say "Found: $1" if "catnip" =~ /(...)/i; say "Found again: $1" if "dognip" =~ /$want/; say ${^LAST_SUCCESSFUL_PATTERN}'
Found: cat
Found again: dog
(?^ui:(...))
#
# Better to use qr{}:
perl -E '$want = qr{}; say "Found: $1" if "catnip" =~ /(...)/i; say "Found again: $1" if "dognip" =~ /$want/; say ${^LAST_SUCCESSFUL_PATTERN}'
Found: cat
Found again:
(?^u:)
#############################################################
## Perl Regular Expressions - Captures
#############################################################
# Perl Regular Expressions - Captures
dye( $', "YELLOW" ),
);
}
#############################################################
## Perl Regular Expressions - Extended
#############################################################
# Inside (?{}) regex code, $_ is set to the string value.
perl -E 'say 123 =~ /\d \d (?{ say "[$_] " . pos}) /x'
[123] 2
1
# \G to make sure pattern starts at previous location.
# /gc to continue in case of failure.
perl -E '$_ = "abc123"; say $1 if /\G(ab)/gc; say $1 if /\G([a-z]+\d)/gc; say $1 if /(\d+)/gc'
ab
c1
23
# Pos is only affected by /g or /gc.
perl -E '$_ = "abc123"; say $1 if /\G(ab)/gc; say $1 if /\G([a-z]+\d)/gc; say pos; /.+/; say pos; say $1 if /(\d+)/gc'
ab
c1
4
4
23
# Perl Regular Expressions - Extended
# https://perldoc.perl.org/perlretut#Using-independent-subexpressions-to-prevent-backtracking
#
# Possesive quantifier, atomic sub expression,
# and previous global match anchor.
perl -E '$_ = "ab"; say 11 if /a*ab/'
11
perl -E '$_ = "ab"; say 11 if /a*+ab/'
perl -E '$_ = "ab"; say 11 if /(?>a*)ab/'
#
# Control verb in v5.32
perl -E '$_ = "ab"; say 11 if /(*atomic:a*)ab/'
#
# Similar to having 2 separate expressions:
perl -E '$_ = "ab"; say 11 if /a*/g; say 22 if /\Gab/'
11
perl -E '$_ = "ab"; say 11 if /a*/g; say 22 if /\Gab/g'
11
# Perl Regular Expressions - Extended
# Using local versus lexical in code eval.
perl -E '$_ = "aaa"; $c = 0; / ^ (?: a (?{ $c++ }) )* $ /x; say "Found $c a"'
Found 3 a
#
# WRONG!
perl -E '$_ = "aaab"; $c = 0; / ^ (?: a (?{ $c++ }) )* $ /x; say "Found $c a"'
Found 3 a
#
# Using local - more complicated, but works on failures.
perl -E '$_ = "aaa"; $c = 0; / ^ (?{ local $_c = 0 }) (?: a (?{ $_c++ }) )* $ (?{ $c = $_c }) /x; say "Found $c a"'
Found 3 a
perl -E '$_ = "aaab"; $c = 0; / ^ (?{ local $_c = 0 }) (?: a (?{ $_c++ }) )* $ (?{ $c = $_c }) /x; say "Found $c a"'
Found 0 a
#
# Using my - same:
perl -E '$_ = "aaa"; $c = 0; / ^ (?{ my $_c = 0 }) (?: a (?{ $_c++ }) )* $ (?{ $c = $_c }) /x; say "Found $c a"'
Found 3 a
perl -E '$_ = "aaab"; $c = 0; / ^ (?{ my $_c = 0 }) (?: a (?{ $_c++ }) )* $ (?{ $c = $_c }) /x; say "Found $c a"'
Found 0 a
#############################################################
## Perl Regular Expressions - Extended - Dynamic
#############################################################
# Perl Regular Expressions - Extended - Dynamic
# Dynamic regex and eval code are not working as first expected.
# Not like a closure.
perl -E '
use strict;
use warnings;
my $num = 111;
my $regex;
{
$num = 222;
$regex = qr{
(?{ say $num })
(??{ $num })
}x
}
$num = 333;
say "333" =~ /$regex/;
'
333
1
# Dynamic regex and eval code are not working as first expected.
# From function.
# Not like a closure.
perl -E '
use strict;
use warnings;
sub make {
my $num = 222;
my $regex = qr{
(?{ say $num })
(??{ $num })
}x
}
my $r = make(); say "333" =~ /$r/;
'
# Dynamic regex and eval code are not working as first expected.
# From different package function.
# Not like a closure.
perl -E '
use strict;
use warnings;
package P1;
sub make {
my $num = 222;
my $regex = qr{
(?{ say $num })
(??{ $num })
}x
}
package P2;
my $r = P1::make(); say "333" =~ /$r/;
'
# Dynamic regex and eval code are not working as first expected.
# Join re-evaluates a regex.
perl -E '
use re "eval"; use strict;
use warnings;
my $reg1;
my $reg2;
{
my $num = 111;
$reg1 = qr{ (??{ print $num; $num }) }x;
$num = 222;
$reg2 = qr{ (??{ print $num; $num }) }x;
}
my $regex_str = join "", $reg1, $reg2;
my $regex = qr{ ^ $regex_str $ }x;
say "222" =~ /$regex/;
'
Global symbol "$num" requires explicit package name (did you forget to declare "my $num"?) at (eval 1) line 1.
Global symbol "$num" requires explicit package name (did you forget to declare "my $num"?) at (eval 1) line 1.
Global symbol "$num" requires explicit package name (did you forget to declare "my $num"?) at (eval 1) line 1.
Global symbol "$num" requires explicit package name (did you forget to declare "my $num"?) at (eval 1) line 1.
# Dynamic regex and eval code are not working as first expected.
# This way is ok to use.
perl -E '
use strict;
use warnings;
my $reg1;
my $reg2;
{
my $num = 111;
$reg1 = qr{
(?{ say $num })
(??{ $num })
}x;
$num = 222;
$reg2 = qr{
(?{ say $num })
(??{ $num })
}x;
}
my $regex = qr{ $reg1 $reg2 }x;
say "222222" =~ /$regex/
'
222
222
1
#############################################################
## Perl Regular Expressions - Extended - $^R
#############################################################
# Perl Regular Expressions - Extended - $^R
# Example of using $^R to store sub matches.
perl -Me -e '$_ = "One fish two fish really red fish blue fish"; say "Before: ", $^R // "undef"; { local $^R = []; / ^ (?> \s*+ (?> (?<name>\w+) \s+ fish (?{ [ $^R->@*, $+{name} ] }) | (?: (?! \b fish \b ) . )*+ fish ) )+ /xg; p $^R; p \%+; p \%- }; ...
Before: undef
[
[0] "One",
[1] "two",
[2] "blue",
]
{
name => "blue",
} (tied to Tie::Hash::NamedCapture)
{
name => [
[0] "blue",
],
} (tied to Tie::Hash::NamedCapture)
After: undef
# Perl Regular Expressions - Extended - $^R
# Failure reverts changes to scoped variables.
perl -Me -e '$_ = "One fish two fish really red fish blue fish"; say "Before: ", $^R // "undef"; { local $^R = []; / ^ (?> \s*+ (?> (?<name>\w+) \s+ fish (?{ [ $^R->@*, $+{name} ] }) | (?: (?! \b fish \b ) . )*+ fish ) )+ (*F) /xg; p $^R; p \%+; p \%...
Before: undef
[]
{} (tied to Tie::Hash::NamedCapture)
{} (tied to Tie::Hash::NamedCapture)
After: undef
#############################################################
## Perl Regular Expressions - Lookaround
#############################################################
# variable length lookaround in any PCRE
# http://www.drregex.com/2019/02/variable-length-lookbehinds-actually.html?m=1
perl -E 'say "ABXXXCD" =~ /(?<=X+)/'
Lookbehind longer than 255 not implemented in regex m/(?<=X+)/ at -e line 1.
#
# Workaround:
perl -E '$r = qr/ (?=(?<a>[\s\S]*)) (?<b> X++ (?=\g{a}\z) | (?<= (?= x^ | (?&b) ) [\s\S] ) )/x; say "ABXXXCD" =~ $r'
perl -E '$r = qr/ (?=(?<a>(?s:.*))) (?<b> X++ (?=\g{a}\z) | (?<= (?= x^ | (?&b) ) (?s:.) ) )/x; say "ABXXXCD" =~ $r'
CD
#
# Explanation:
(?=(?'a'[\s\S]*)) # Capture the rest of the string in "a"
(?'b'
X(?=\k'a'\z) # Match X followed by the contents of "a" to ensure
# the emulated lookbehind stops at the correct point.
| # OR
(?<= # Look behind (one character) match either:
(?=
x^ # A contradiction; non-empty to appease the nanny
| # OR
(?&b) # Recurse (match X OR look behind (one character)) etc..
)
[\s\S] # How far we go back each step: one single character
)
)
# Lagging split using a lookaround.
perl -E 'say for "1234567890" =~ /(?=(...))/g'
123
234
345
456
567
678
789
890
# Lagging split using a lookaround into a table format.
perl -E '@a = "1234567890" =~ /(?=(..))/g; say for map { $a[$_+2] ? "@a[$_..$_+2]" : () } 0..$#a'
12 23 34
23 34 45
34 45 56
45 56 67
56 67 78
67 78 89
78 89 90
# Perl Regular Expressions - Lookaround
# Mimicking atomic grouping with positive lookahead.
ˆ(?=(\w+))\1:
#############################################################
## Perl Regular Expressions - Loops
#############################################################
# Different ways to loop through and extract the 3rd match.
perl -E '$_ = "One fish two fish red fish blue fish"; say+( / (\S+) \s+ fish /xg )[2]'
red
perl -E '$_ = "One fish two fish red fish blue fish"; while ( / (\S+) \s+ fish /xg ) { if (++$c == 3) { say $1; last } }'
red
#############################################################
## Perl Regular Expressions - Modifiers
#############################################################
# Perl Regular Expressions - Modifiers
# The modifier flags can be scoped.
perl -E 'say 111 if "abc" =~ /ABC/'
perl -E 'say 111 if "abc" =~ /(?i)ABC/'
111
perl -E 'say 111 if "abc" =~ /((?i)AB)C/'
perl -E 'say 111 if "abc" =~ /((?i)ABC)/'
111
# Perl Regular Expressions - Modifiers
# These are similar (besides one captures)
perl -E 'say 111 if "abc" =~ /((?i)AB)C/'
perl -E 'say 111 if "abc" =~ /(?i:AB)C/'
# Expand variables in single quotes. (Regex,eval)
perl -E '
$AGE = 21;
$_ = q(I am $AGE years old);
s/(\$\w+)/$1/eeg;
say;
'
I am 21 years old
(?&LOOP)
(?(DEFINE)
(?<LOOP>
\(
(?> [^()] | (?&LOOP) )*
\)
)
)
}x;
while (/\b (\w+ \s* ($r)) /x){
say $1;
$_ = $2;
}
#############################################################
## Perl Regular Expressions - Sets
#############################################################
# Any number but 5 (regex sets,char class).
# https://perldoc.perl.org/perlrecharclass#Extended-Bracketed-Character-Classes
perl -E 'say for map { "$_: " . /^ (?[ \d - [5] ])+ $/x } qw/ 12 15 18 /'
perl -E 'say for map { "$_: " . /^ [0-46-9]+ $/x } qw/ 12 15 18 /'
perl -E 'say for map { "$_: " . (/^\d+$/ && !/5/) } qw/ 12 15 18 /'
12: 1
15:
18: 1
#############################################################
## Perl Regular Expressions - Subpatterns
#############################################################
# Create a subpattern using:
# (?<name>pattern)
# )
# It is recommended that for this usage you put the DEFINE
# block at the end of the pattern, and that you name any
# subpatterns defined within it.
#
# Then use it like:
# (?&name)
#
# Example:
perl -E '"look mk" =~ / (l (?&same_char) )k \s (.)k (?(DEFINE) (?<same_char> (.) \g{-1} ) ) /x; say "got: 1:$1, 2:$2, 3:$3, 4:$4"'
# Check for existence of a capture group.
# Can use either:
# - ({ exists $+{var} })
# - (?<var>IF|ELSE)
perl -E '
"abc" =~ /
(?{ say exists $+{var} ? 1 : 0 })
(?(<var>)
(?{ say "if" })
| (?{ say "else" })
)
(?<var> . )
(?{ say exists $+{var} ? 1 : 0 })
(?(<var>)
(?{ say "if" })
| (?{ say "else" })
)
/x
'
0
else
1
if
#############################################################
#############################################################
# Perl regex verbs shoukd be benchmarked before
# being used since the additional compilation time
# might not justify the performance improvement.
# Great place to learn more about backtracking control verbs in regex.
# https://www.rexegg.com/backtracking-control-verbs.html
# Perl regex verb - ACCEPT (example)
perl -E '"0aaab" =~ / (?{ say pos . ":" }) 0* a+ (*ACCEPT) b? (?{ say " $&" }) (*FAIL) /x'
0:
# Perl regex verb - FAIL
# (?=^) matches after a newline.
perl -MEnglish -E 'qq(Aa\nBb\nCc) =~ / (?=^) (?{ say "|$PREMATCH<$MATCH>$POSTMATCH|\n" }) (*F) /smx'
# Perl regex verb - FAIL (example)
# Show all matches.
# Show when shifting position.
perl -E '"0aaab" =~ / (?{ say pos . ":" }) 0* a+ b? (?{ say " $&" }) (*FAIL) /x'
0:
0aaab
0aaa
0aa
0a
1:
aaab
aaa
aa
a
aa
a
3:
ab
a
# Perl regex verb - THEN (Level1,example)
# Mainly to speed up alternations.
# Otherwise it behaves like *PRUNE.
# Appently not necessary in perl due to other optimizations.
perl -E '"123ABC" =~ / 123 B | .{3} /x; say $&'
perl -E '"123ABC" =~ / 123 (*THEN) B | .{3} /x; say $&'
123
# Perl regex verb - PRUNE (Level2, example)
# Will not backtrack past that point.
# Goes right to next position.
# Similar to a possessive quantifier
perl -E '"123ABC" =~ / 123 (*PRUNE) B | .{3} /x; say $&'
23A
# Perl regex verb - SKIP (Level3, example)
# Like *PRUNE, but also advances the string position to after the failure.
perl -E '"123ABC" =~ / 123 (*SKIP) B | .{3} /x; say $&'
ABC
# Perl regex verb - COMMIT (Level4, example)
# All or nothing.
perl -E '"123ABC" =~ / 123 (*COMMIT) B | .{3} /x; say $&'
perl -E '"123ABC" =~ / 1 (*COMMIT) 23 (*PRUNE) B | .{3} /x; say $&'
# empty
#
# SKIP on right inhibits COMMIT.
perl -E '"123ABC" =~ / 1 (*COMMIT) 23 (*SKIP) B | .{3} /x; say $&'
ABC
# Perl regex verb - MARK,SKIP
perl -E '"123ABC456" =~ / 123 (*MARK:past_digits) [A-Z]+ (*SKIP) 9.. | .* /x; say $&'
456
perl -E '"123ABC456" =~ / 123 (*MARK:past_digits) [A-Z]+ (*SKIP:past_digits) 9.. | .* /x; say $&'
ABC456
# Perl regex verb - MARK
perl -E '"1x2" =~ /(?:x(*MARK:x)|y(*MARK:y)|z(*MARK:z))/; say $^N'
perl -E '"1x2" =~ /(?:x(*MARK:mx)|y(*MARK:my)|z(*MARK:mz))/; say $REGMARK'
# Use atomic script runs to prevent named attacks. (paypal.com,perl regex verb ASR)
perl -C -E 'say "\N{CYRILLIC SMALL LETTER ER}aypal.com" =~ /^\w+\.com$/' # 1
perl -C -E 'say "\N{CYRILLIC SMALL LETTER ER}aypal.com" =~ /(*asr:^\w+\.com$)/' # 0
# Control verb: FAIL versus split.
perl -Me -e 'n { split => sub{ my %c; $c{lc($_)}++ for split("", "supercalifragilisticexpialidocious") }, fail => sub { my %c; "supercalifragilisticexpialidocious" =~ /([aeiou])(?{ $c{$1}++; })(*FAIL)/i } }, 1000000'
Rate fail split
fail 114679/s -- -17%
split 137741/s 20% --
#############################################################
## Perl Regular Expressions - Word Boundary
#############################################################
# Normal word boundary.
perl -E "say for q(Tim's favorite candy) =~ /(\b\w.*?\b)/g"
Tim
s
favorite
candy
# More precise and newer word boundary.
# Available from v5.22.
# https://perldoc.perl.org/perlrebackslash#%5Cb%7B%7D%2C-%5Cb%2C-%5CB%7B%7D%2C-%5CB
perl -E "say for q(Tim's favorite candy) =~ /(\b{wb}\w.*?\b{wb})/g"
Tim's
favorite
candy
# More precise and newer word boundary.
# Only with word like characters
# (not double quotes).
perl -E 'say for q(Tim"s favorite candy) =~ /(\b{wb}\w.*?\b{wb})/g'
Tim
s
favorite
candy
#############################################################
## Perl Signal Handling
#############################################################
# Catch Control-C
perl -lE '$SIG{INT}=sub{die "\n\nYou hit control C\n\n"}; say "Press Enter" and <> while 1'
# Assign many signal handlers
perl -MData::Dumper -lE 'sub pr{my $d=Data::Dumper->new(\@_)->Purity(1); say $d->Dump} $SIG{INT}=sub{die"\nINT\n"}; $SIG{QUIT}=sub{die"\nQUIT\n"}; $SIG{TERM}=sub{die"\nTERM\n"}; $SIG{PIPE}=sub{die"\nPIPE\n"}; $SIG{ALRM}=sub{die"\nALRM\n"}; $SIG{HUP}...
# Assign many signal handlers
perl -MData::Dumper -le 'sub pr{print Data::Dumper->new(\@_)->Deparse(1)->Dump} for my $s(qw/INT QUIT TERM PIPE ALRM HUP CHLD __WARN__ __DIE__/){ $SIG{$s} = sub{die"\n$s\n"}} pr \%SIG; <> while 1'
perl -MData::Dumper -le 'sub pr{print Data::Dumper->new(\@_)->Deparse(1)->Dump} for my $s(keys %SIG){ $SIG{$s} = sub{print "\n$s\n"}} pr \%SIG; print $$; <> while 1'
# Alarm signal handler
perl -le 'for my $s(qw/INT QUIT TERM PIPE ALRM HUP CHLD/){ $SIG{$s} = sub{die"\n$s\n"}} alarm 2; <> while 1'
perl -le '$SIG{ALRM}=sub{die"\n\nEND OF TIME\n\n"}; alarm 1; <> while 1'
# Perl signal handling (eval,die,exit)
perl -E 'eval { exit 1 }; say $@; say "here"' # Blank
perl -E 'eval { exit 0 }; say $@; say "here"' # Same
perl -E 'eval { return 1 }; say $@; say "here"' # Return early from an eval. ürints "here"
perl -E 'eval { die }; say $@; say "here"' # caught die, prints "here"
perl -E 'eval { exit 1 }; say $@; END {say "here"}' # Run before final exit. prints "here"
perl -E 'eval { die }; say $@; END {say "here"}' # Same.
perl -E 'open FH, ">", "file"; say FH "123"; exit 1' # File closed and contains "123"
# Perl signal handling (eval,die,exit)
# Avoid using $SIG{__DIE__}
https://www.perlmonks.org/?node_id=1173708
perl -E '$SIG{__DIE__} = sub { say "caught die!" }; die; say $@; say "here"'
# Perl signal handling (eval,die,exit)
# Catch exit command.
perl -E 'BEGIN{ *CORE::GLOBAL::exit = sub(;$){die "EXIT_OVERRIDE: @_\n"} } eval { exit 1 }; print "caught error: $@" if $@; say "here"; exit 0'
# Perl signal handling (eval,die,exit)
# exit overrite snippet. Plus capture all signals.
# exit overrite snippet. Plus capture all signals.
our $ExitOverride = 1;
BEGIN {
*CORE::GLOBAL::exit = sub {
die "EXIT_OVERRIDE:Caught: @_\n" if $ExitOverride;
CORE::exit(@_);
};
$SIG{$Key} = sub { die $Key }; ## no critic
}
#
# RUN CODE HERE
#
$ExitOverride = 0;
# Perl signal handling (eval,die,__DIE__)
# Capture STDOUT and STDERR.
# Catch die and throw to STDOUT.
perl -MApp::Pod -E '{ local *STDOUT; open STDOUT, ">", \$out or die $!; local *STDERR; open STDERR, ">>", \$err or die $!; print "print-out"; print STDERR "print-err"; local $SIG{__DIE__} = sub{ my $m = shift; chomp $m; print STDERR "<$m>" }; eval{di...
#
# Use $@ to capture eval error.
# Better than SIG{__DIE__} since sub calls may except an die
# to stop something, like Pod::Simple, which is used by Pod::LOL).
perl -Ilib -MApp::Pod -E '{ local *STDOUT; open STDOUT, ">", \$out or die $!; local *STDERR; open STDERR, ">>", \$err or die $!; print "print-out"; print STDERR "print-err"; eval{die "die\n"}; print STDERR "<$@>" if $@; print "print-out2" } say "\n[$...
# Redirect to terminal even when STDOUT and/STDERR are sent somewhere else.
perl -E 'open my $fh, ">", "/dev/tty" or die $!; close *STDOUT; say $fh "111"; say "HERE"; say $fh "123";'
111
123
pod e say
# Perl Signal Handling
# Another interesting signal is signal number 0.
# This doesn’t actually affect the target process,
# but instead checks that it’s alive and hasn’t
# changed its UIDs. That is, it checks whether
# it’s legal to send a signal, without actually
...
};
$code->();
# Give a name to an anonymous sub/function.
# Outside the sub.
use Sub::Util;
*{"${class}::$_"} = set_subname("${class}::$_", $patch{$_}) for keys %patch;
# Perl typeglob adding a method to an object (symbol table)
perl -E 'package A { sub a{123} } $o = bless {}, "A"; *{(ref $o) . "::b"} = sub{345}; say $o->b'
# Delete a perl function using (typeglob,symbol table)
# It does not seem possible to localize a "delete":
*My::Run = *EMPTY # Overwrite write an empty symbol table.
delete $A::{a};
delete *{A::}->{a};
delete ${"$pkg\::"}{a};
#
# Instead, just reassign the entire typeglob: (symbol table)
perl -E 'sub Pkg::Func{say 123} $o = bless {}, "Pkg"; {local *Pkg::Func = *Blank; } $o->Func'
# Old school Moose (symbol table, typeglob)
perl -E '
{
package ABC;
sub func{ say "func" }
}
{
my $Orig = \&ABC::func;
local *ABC::func = sub {
say "pre";
$Orig->();
say "post";
};
ABC->func;
};
say "\nreverted";
ABC->func
'
# Moose way to use around (symbol tyble, typeglob)
# DO NOT USE!
# It keeps wrapping the function.
perl -MMoose -E '
{
package ABC;
use Moose;
sub func{ say "func" }
}
{
Moose::around "ABC", func => sub {
my ($Orig,$Self,%Param) = @_;
say "pre";
$Orig->($Self,%Param);
say "post";
};
ABC->func;
}
say "\nreverted";
ABC->func
'
# Sub::Override way to temporarily replace a function (symbol table, typeglob)
perl -MSub::Override -E '
{
package ABC;
sub func{ say "func" }
}
for (1..3) {
my $sub = Sub::Override->new( "ABC::func" => sub {
say "pre";
say "post";
});
ABC->func;
};
say "\nreverted";
ABC->func
'
# Sub::Override way to temporarily replace a function (symbol table, typeglob)
# Also gets the orignal sub name.
perl -MSub::Override -E '
{
package ABC;
sub func{ say "func" }
}
for (1..3) {
my $sub;
$sub = Sub::Override->new( "ABC::func" => sub {
say "pre";
$sub->{"ABC::func"}->();
say "post";
});
ABC->func;
};
say "\nreverted";
ABC->func
'
# Override a function in perl.
perl -E '
package P;
my $Obj = bless {}, "P";
my $Class = ref $Obj;
*{"${Class}::RunMe"} = sub { say "hello world" };
P::RunMe();
$Obj->RunMe();
'
# For loop makes an alias of each element.
# Changes to the alias also change the element.
perl -E 'my $v = 111; $_ = 222 for $v; say $v'
222
#
# Similar way to make an alias to a variable.
perl -E 'my $v = 111; { local *_ = \$v; $_ = 222 } say $v'
222
# Perl Symbol Table
# Stash - hash like structure describing all
# package variables
%main::
%My_Package::
# Perl Symbol Table
# Type glob magic - only the type gets modified.
*foo = \$scalar;
*foo = \@array;
#############################################################
## Perl Unicode - General
#############################################################
# Create invalid Malformed UTF-8 character (unicode)
perl -C -Me -MEncode -E 'my $v = "a\372z"; dd $v; Encode::_utf8_on($v); say ""; dd $v; say $v'
# Check if valid utf8 (unicode)
Encode::is_utf8( $Param{Text}, 1 )
utf8::valid( $Param{Text} )
# Pick a unicode character at a time.
perl -Mutf8 -C -E 'say for "äö" =~ /(\X)/g'
ä
ö
perl -Mutf8 -C -E 'say for "äö" =~ /(.)/g'
ä
ö
#############################################################
## Perl Unicode - Codes
#############################################################
# Unicode salute/saluting.
perl -C -E 'say "\x{1FAE1}"'
🫡
# Draw a box with unicode in perl.
perl -C -E 'say "\N{BOX DRAWINGS LIGHT ARC DOWN AND RIGHT}" . ("\N{BOX DRAWINGS LIGHT HORIZONTAL}" x 5) . "\N{BOX DRAWINGS LIGHT ARC DOWN AND LEFT}"; say "\N{BOX DRAWINGS LIGHT VERTICAL} \N{BOX DRAWINGS LIGHT VERTICAL}" for 1..2; say "\N{BOX DRAW...
# Unicode error codes:
➜ HEAVY ROUND-TIPPED RIGHTWARDS ARROW U+279c 0x279c 10140 023634
✖ HEAVY MULTIPLICATION X U+2716 0x2716 10006 023426
# Unicode star
★ BLACK STAR U+2605 0x2605 9733 023005
#############################################################
## Perl Unicode - Mojibake
#############################################################
# Perl mojibake guide.
https://dev.to/drhyde/a-brief-guide-to-perl-character-encoding-if7
# Perl mojibake examples. (wrong length)
perl -E '$s = "é"; say $s . " contains " . length($s) . " chars"'
é contains 2 chars
# Perl mojibake examples. (utf8 is not enough)
perl -Mutf8 -E '$s = "é"; say $s . " contains " . length($s) . " chars"'
� contains 1 chars
# Perl mojibake examples. (-C or binmode to get correct encoding and therefore length)
perl -Mutf8 -E 'binmode(STDOUT, ":encoding(UTF-8)"); $s = "é"; say $s . " contains " . length($s) . " chars"'
perl -Mutf8 -C -E '$s = "é"; say $s . " contains " . length($s) . " chars"'
perl -Mutf8 -C -E 'binmode(STDOUT, ":encoding(UTF-8)"); $s = "é"; say $s . " contains " . length($s) . " chars"'
é contains 1 chars
# Perl mojibake examples. (Simulate malformed UTF-8 character warnings)
echo '"key": "é"' > my.out
iconv -f utf-8 -t latin1 my.out > my2.out
file my*.out
cat my*
"key": "�"
"key": "é"
cat my2.out | perl -Mutf8 -C -lne '/\d/'
- ":encoding(UTF-8)" should be preferred over ":utf8"
- Use "utf8::valid" to check for malformed strings.
# iconv using perl (piconv)
# Saves a file using wrong encoding (mojibake)
perl -CA -le 'open OUT, ">:encoding(latin1)", "my3.out" or die $!; print OUT shift' '"key": "é",'
# Find non ascii characters.
perl -C -lne 'print $1 if /([^[:ascii:]])/' my.yml
uni_convert --string "$(perl -C -lne 'print $1 if /([^[:ascii:]])/' my.csv)"
echo 'aböc' | perl -nE 'say "[$1]" if /(\P{ASCII}+)/'
#############################################################
## Perl Unicode - Encode/Decode
#############################################################
# Compare use of encode/decode.
# Start with non unicode.
perl -C -MEncode -Mutf8 -C -Me -e '$_ = "\xef\xac\xa1"; my $en = eval{encode("UTF-8", $_)} // ""; my $de = eval{decode("UTF-8", $_)} // ""; say; say $en; say $de; dd $_; dd $en, dd $de'
ﬡ
ﬡ
ﬡ
SV = PV(0xb40000740302de60) at 0xb4000074030a9be8
REFCNT = 1
FLAGS = (POK,IsCOW,pPOK)
PV = 0xb400007382ce28a0 "\xEF\xAC\xA1"\0
CUR = 3
LEN = 16
COW_REFCNT = 1
LEN = 16
SV = PV(0xb40000740302dea0) at 0xb40000740301f930
REFCNT = 1
FLAGS = (POK,pPOK)
PV = 0xb400007382ce2d70 "\xC3\xAF\xC2\xAC\xC2\xA1"\0
CUR = 6
LEN = 16
# Compare use of encode/decode.
# Start with unicode.
perl -C -MEncode -Mutf8 -C -Me -e '$_ = "\x{fb21}"; my $en = eval{encode("UTF-8", $_)} // ""; my $de = eval{decode("UTF-8", $_)} // ""; say; say $en; say $de; dd $_; dd $en, dd $de'
ﬡ
ﬡ
SV = PV(0xb40000721e02de60) at 0xb40000721e0a2be8
REFCNT = 1
FLAGS = (POK,IsCOW,pPOK,UTF8)
PV = 0xb40000719dce28a0 "\xEF\xAC\xA1"\0 [UTF8 "\x{fb21}"]
CUR = 3
LEN = 16
COW_REFCNT = 1
SV = PV(0xb40000721e034590) at 0xb40000721e0a23a8
COW_REFCNT = 1
SV = PV(0xb40000721e02dea0) at 0xb40000721e01f930
REFCNT = 1
FLAGS = (POK,pPOK)
PV = 0xb40000719dce2d70 "\xEF\xAC\xA1"\0
CUR = 3
LEN = 16
# Compare use of encode/decode.
# Start with name (must be upper case).
perl -C -MEncode -Mutf8 -C -Me -e '$_ = "\N{HEBREW LETTER ALEF}"; my $en = eval{encode("UTF-8", $_)} // ""; my $de = eval{decode("UTF-8", $_)} // ""; say; say $en; say $de; dd $_; dd $en, dd $de'
×
×
SV = PV(0xb400007267a2de60) at 0xb400007267aa0be8
REFCNT = 1
FLAGS = (POK,IsCOW,pPOK,UTF8)
PV = 0xb400007267a2c0c0 "\xD7\x90"\0 [UTF8 "\x{5d0}"]
CUR = 2
LEN = 16
COW_REFCNT = 1
SV = PV(0xb400007267a2e0b0) at 0xb400007267a1f948
LEN = 16
COW_REFCNT = 1
SV = PV(0xb400007267a2dea0) at 0xb400007267a1f930
REFCNT = 1
FLAGS = (POK,pPOK)
PV = 0xb4000071e774e170 "\xD7\x90"\0
CUR = 2
LEN = 16
# Display ALEF from different ways.
perl -C -E 'say "\N{HEBREW LETTER ALEF}"' ×
perl -C -E 'say "\N{U+5d0}"' ×
perl -C -E 'say "\x{5d0}"' ×
perl -C -E 'say chr(0x5d0)' ×
perl -C -E 'say chr(0x05d0)' ×
perl -C -E 'say chr(1488)' ×
perl -C -E 'say v1488' ×
# To and from Unicode code point and unnicode byte stream.
perl -C -Me -e 'say unpack "H*", enc "\x{5d0}"'
d790
#
perl -C -Me -e 'say unpack "U*", "\x{5d0}"'
1488
#############################################################
## Perl Object (before class keyword)
#############################################################
# Different ways to check if an object is a certain class.
perl -E 'my $v = 1; say ref $v'
perl -E 'my $v = bless {}, "Cat"; say ref $v'
perl -E 'my $v = bless {}, "Cat"; say $v isa "Cat"'
perl -E 'my $v = bless {}, "Cat"; say $v->isa("Cat")'
perl -E 'my $v = bless {}, "Cat"; say UNIVERSAL::isa($v,"Cat")'
#############################################################
## Perl Class Keyword
#############################################################
# Since 5.38.0, can use 'class' instead of 'package' for a postmodern OOP.
# Perl class documentation.
perlbrew use perl-5.38.0
perldoc class
# Simple example using perl class.
perl -E 'use feature qw(class); no warnings qw(experimental::class); class Point { field $x :param; method show { say $x } } Point->new(x => 333)->show'
333
# Using a different name for the parameter.
perl -E 'use feature ":all"; no warnings "experimental::class"; class Point 1.2 { field $x :param(_x); method show { say $x } } Point->new(_x => 111)->show'
111
# Perl class - class block/statement.
#
# Block form:
perl -E 'use experimental "class"; class C { field $name = "bob"; method say_hi(){ say "Hi $name" } } C->new->say_hi'
Hi bob
#
# Statement form:
perl -E 'use experimental "class"; class C; field $name = "bob"; method say_hi(){ say "Hi $name" } package main; C->new->say_hi'
Hi bob
# Perl class - fields.
#
# Cannot access field outside.
perl -E 'use experimental "class"; class C { field $id } say C->new'
#
# field vs my.
perl -E 'use experimental "class"; class C { my $count = 1; field $id = $count++; method id { $id } } say C->new->id; say C->new->id;'
1
2
# Perl class - :param field attribute.
#
# There is a check to present unrecognised data from being passed to the constructor.
perl -E 'use experimental "class"; class C { field $id; method id { $id } } say C->new( id => 123)->id'
Unrecognised parameters for "C" constructor: id at -e line 1.
#
# Use :param to allow setting that field.
perl -E 'use experimental "class"; class C { field $id :param; method id { $id } } say C->new( id => 123)->id'
123
#
# The :param attribute by deault makes the parameter to be required.
perl -E 'use experimental "class"; class C { field $id :param; method id { $id } } say C->new->id'
Required parameter 'id' is missing for "C" constructor at -e line 1.
# Perl class - :param field attribute.
# Specify a default for a required parameter class.
#
# :param =
perl -E 'use experimental "class"; class C { field $id :param = "ZZZ"; method id { $id } } say C->new->id'
ZZZ
perl -E 'use experimental "class"; class C { field $id :param = "ZZZ"; method id { $id } } say C->new( id => 111)->id'
111
perl -E 'use experimental "class"; class C { field $id :param = "ZZZ"; method id { $id } } say C->new( id => undef )->id'
[empty]
#
# :param //=
perl -E 'use experimental "class"; class C { field $id :param //= "ZZZ"; method id { $id } } say C->new( id => undef )->id'
ZZZ
perl -E 'use experimental "class"; class C { field $id :param //= "ZZZ"; method id { $id } } say C->new( id => 0 )->id'
0
#
# :param ||=
perl -E 'use experimental "class"; class C { field $id :param ||= "ZZZ"; method id { $id } } say C->new( id => 0 )->id'
ZZZ
perl -E 'use experimental "class"; class C { field $id :param ||= "ZZZ"; method id { $id } } say C->new( id => 111 )->id'
111
# Perl class - method statement.
# In the scope of a method block, $self is already defined.
# Also, signatures are enabled for methods.
perl -E 'use experimental "class"; class C { method me { $self } } say C->new->me'
C=OBJECT(0x5599190527b0)
# Perl class - method statement.
#
# method can also return an anonymous method (but this is a fix confusing looking).
perl -E 'use experimental "class"; class C { method me { return method { say "Found me" } } } my $obj = C->new; my $code = $obj->me(); $obj->$code'
Found me
perl -E 'use experimental "class"; class C { method me { return method { say "Found me" } } } my $obj = C->new; my $code = $obj->me(); $code->($obj)'
Found me
# Perl class - Attributes.
# Perl class - Lifecycle hooks
#
# ADJUST method hook is called during new().
perl -E 'use experimental "class"; class C { field $greetings; ADJUST { $greetings = "Hello"; say "Setting greetings to $greetings" } method greet ($name = "someone") { say "$greetings, $name" } say "END class" } C->new'
END class
Setting greetings to Hello
#
perl -E 'use experimental "class"; class C { field $greetings; ADJUST { $greetings = "Hello"; say "Setting greetings to $greetings" } method greet ($name = "someone") { say "$greetings, $name" } say "END class" } C->new->greet("Bob")'
END class
Setting greetings to Hello
Hello, Bob
# Perl class - Guide 0.
perl -E 'use experimental "class"; use Games::ROT; class Engine { field $height :param; field $width :param; field $app = Games::ROT->new( screen_width => $width, screen_height => $height ); ADJUST { $app->run(sub{ $self->render() })} method render()...
# Perl class - Guide 1.
perl -E 'use experimental "class"; use Games::ROT; class Engine { field $height :param; field $width :param; field $app = Games::ROT->new( screen_width => $width, screen_height => $height ); ADJUST { $app->add_event_handler( keydown => sub($event){ e...
#############################################################
## Perl Functions - General
#############################################################
# Lexical sub in perl (function)
perl -wE '{my sub fun {say 123} } fun'
# push, pop, shift, unshift are special since if the target is undef,
# they will change the target to be an empty array reference.
#
# These produce an error: "Can't use an undefined value as an ARRAY reference at ..."
perl -Mojo -E 'my $h = {}; @{$h->{list}}; say "ok"'
perl -Mojo -E 'my $h = {}; my $v = @{$h->{list}}; say "ok"'
perl -Mojo -E 'my $h = {}; my $v = scalar @{$h->{list}}; say "ok"'
perl -Mojo -E 'my $h = {}; say @{$h->{list}}; say "ok"'
perl -Mojo -E 'my $h = {}; my @copy = @{$h->{list}}; say "ok"'
#
# Where as these are ok:
perl -Mojo -E 'my $h = {}; push @{$h->{list}}, 123; say "ok"'
perl -Mojo -E 'my $h = {}; pop @{$h->{list}}; say "ok"'
perl -Mojo -E 'my $h = {}; shift @{$h->{list}}; say "ok"'
perl -Mojo -E 'my $h = {}; unshift @{$h->{list}}, 123; say "ok"'
perl -Mojo -E 'my $h = {}; say @{$h->{list} // []}; say "ok"'
# Signatures no longer experimental in v5.36
perl -E 'sub F($n){ $n*2 } say F(5)'
10
#############################################################
## Perl Functions - Arguments
#############################################################
# Perl Functions - Arguments
# Diffierent ways to call a function.
perl -E '
package P;
sub Method { say "[@_]" }
sub Run {
__PACKAGE__->Method(222); # [P 222]
__PACKAGE__->can("Method")->(222); # [222]
caller->Method(222); # [P 222]
caller->can("Method")->(222); # [222]
}
Run
'
}
return @items;
}
my @list = (1,2,3);
@list = my_map {$_+10} @list;
print "@list";
'
11 12 13
# View prototype of a function.
perl -E 'say prototype "CORE::splice"'
\@;$$@
# Perl function prototype options.
# The special + prototype takes care of this for
# you as a shortcut for \[@%].
# Perl function prototype options.
# You can use the backslash group notation,
# \[], to specify more than one allowed
# backslashed argument type.
place of $. If this argument is not provided,
the current $_ variable will be used instead
# Perl function prototype options.
# Calls made using &NAME are never inlined, however,
# just as they are not subject to any other prototype
# effects.
# Can use :prototype(_) to pass in $_ to @_ when
# there is no input.
perl -E 'sub say2 :prototype(_) { say "[@_]"; CORE::say(@_) } say2 123'
[123]
123
perl -E 'sub say2 :prototype(_) { say "[@_]"; CORE::say(@_) } say2 for 1..3'
[1]
1
[2]
2
[3]
3
#############################################################
## Perl Functions - Recursion
}
}
}
#############################################################
## Perl Functions - flock
#############################################################
# Simple example of flock.
# Wait indefinitely for a lock.
perl -E 'use Fcntl ":flock"; open $fh, "+>>", "my.txt" or die $!; flock $fh, LOCK_EX or die $!; say $fh 111; sleep 10'&
perl -E 'use Fcntl ":flock"; open $fh, "+>>", "my.txt" or die $!; flock $fh, LOCK_EX or die $!; say $fh 222'
# Flock perl explanation/guide.
https://www.perlmonks.org/?node_id=7058
https://perl.plover.com/yak/flock/
#############################################################
## Perl Functions - fork
#############################################################
# Run a child in a separate process and wait for it.
perl -E 'my $PID = fork; if (!$PID){ sleep 2; say "child"; exit 0 } waitpid $PID, 0; say "parent"'
# Send data from forked child back to parent using pipes.
perl -E 'pipe(INPUT,OUTPUT); my $PID = fork; if (!$PID){ close INPUT; sleep 1; say "child"; say OUTPUT "42"; close OUTPUT; exit 0 } close OUTPUT; waitpid $PID, 0; say "parent"; my ($Data) = <INPUT>; say "[$Data]"'
# Run multiple processes and collect their data.
perl -MMojo::Util=dumper -E 'use strict; use warnings; local $| = 1; my @Wait; for my $Count (1..5){ my($In,$Out); pipe($In,$Out); my $PID = fork; if (!$PID){ close $In; sleep int(rand(5)); say "Running child $Count"; say $Out "From-$Count"; close $O...
Running child 2
Running child 3
Running child 4
Running child 5
Running child 1
parent is reading now pid: 593943
parent is reading now pid: 593944
parent is reading now pid: 593945
parent is reading now pid: 593946
parent is reading now pid: 593947
],
"593946" => [
"From-4"
],
"593947" => [
"From-5"
]
}
# Run multiple processes and collect their data (no debug output).
perl -MMojo::Util=dumper -E 'use strict; use warnings; local $| = 1; my @Wait; for my $Count (1..200){ my($In,$Out); pipe($In,$Out); my $PID = fork; if (!$PID){ close $In; sleep int(rand(5)); say $Out "From-$Count"; close $Out; exit 0 } close $Out; p...
# Run multiple processes and collect their data.
# Sends a structure back from the children.
perl -Mojo -E 'local $| = 1; my @Wait; for my $Count (1..5){ my($In,$Out); pipe($In,$Out); my $PID = fork; if (!$PID){ close $In; sleep int(rand(5)); say $Out j { Title => "From-$Count", Count => $Count }; close $Out; exit 0 } close $Out; push @Wait,...
{
"1" => {
"ChildPid" => 28843,
"Count" => 1,
"Title" => "From-1"
},
"2" => {
"ChildPid" => 28844,
"Count" => 2,
"Title" => "From-2"
"Title" => "From-4"
},
"5" => {
"ChildPid" => 28847,
"Count" => 5,
"Title" => "From-5"
}
}
# Process killing example:
perl -E '$pid = fork; if (!$pid){ say "[$$] child", sleep 1 while 1 } else { say "[$$] parent"; waitpid $pid, 0; say "[$$] parent end" }'
perl -E '$pid = fork; if (!$pid){ say "[$$] child", sleep 1 while 0; say "start"; system qq(google-chrome --headless --virtual-time-budget=15000 --window-size=200,200 --screenshot=$ENV{HOME}/Downloads/my.png log); say "wait"; sleep 10 } else { say "...
#
perl -E 'for ( shift ) { say kill 0, $_; sleep 1; say kill -9, $_; sleep 1; say kill 0, $_ }' 3022126
#############################################################
## Perl Functions - getpwnam, getgrent, getgrnam, getgrgid
#############################################################
# UID in scalar context, all fields in list
perl -lE '$a=getpwnam("<USER>"); say $a'
perl -lE 'say for getpwnam("<USER>")'
# Group name entry
perl -lE 'say getgrent'
# Get name
perl -lE 'say for getgrnam("systems")'
# Group ID
perl -lE 'say for getgrgid("systems")'
# Get password file entry for a username (check if they exist)
perl -le 'print for getpwnam "<USER>"'
#############################################################
## Perl Functions - local
#############################################################
# Can use local actually with a lexical/my variable.
perl -Mojo -E 'my %h; { local $h{abc}=1; say r \%h } say r \%h'
perl -Mojo -E 'my %h; sub show { say "show: " . r \%h } { local $h{abc}=1; show() } show()'
show: {
"abc" => 1
}
show: {}
# Comparing lexical and global (quite similar).
perl -E 'sub show { my ($ref) = @_; say "$ref $$ref" } my $my = 111; our $our = 222; show \$my; show \$our; { my $my = 112; local $our = 223; show \$my; show \$our } show \$my; show \$our' SCALAR(0xb4000075870a0168) 111...
SCALAR(0xb4000075870a0198) 222
SCALAR(0xb4000075870a1498) 112
SCALAR(0xb40000758701f678) 223
SCALAR(0xb4000075870a0168) 111
SCALAR(0xb4000075870a0198) 222
#############################################################
## Perl Functions - msgsnd, msgrcv
#############################################################
# Send and receive message from the queue (IPC)
perl -le 'msgsnd 99483684, "123456789", 0'
perl -le 'msgrcv 99483684, $var, 24, 0, 0; print "[$var]"'
#############################################################
## Perl Functions - ord
#############################################################
# Show ascii ordinal values
perl -E "say qq($_ ) . chr for 1..227"
perl -E "say qq($_ = ) . ord for qw/ a A ä ö ü ß /"
#############################################################
## Perl Functions - select
#############################################################
# Show the currently selected file handle.
perl -E 'say select'
main::STDOUT
#############################################################
## Perl Functions - split
#############################################################
# Idiom to collapse whitespace.
perl -E 'say for split " ", " i have so many spaces here "'
i
have
so
many
spaces
here
# Separate based on a lookahead position.
perl -E 'say for split /(?=[A-Z])/, "CatBatHat"'
Cat
Bat
Hat
# Separate and show the delimiter also (retension mode)
perl -E 'say for split /(\W)/, "Cat-Bat:Hat"'
Cat
-
Bat
:
Hat
#############################################################
## Perl Functions - sort
#############################################################
# Binary sort and insert in perl
perl -le "@a=(4,10,20); sub add{ my ($n) = @_; print qq(\nAdding: $n); if($n < $a[0]){ unshift @a, $n } elsif($n > $a[-1]){ push @a, $n }else{ my ($first,$last) = (0,$#a); my $mid; while($first < $last){ $mid = $first + int(($last-$first)/2); print q...
#############################################################
## Perl Functions - srand
#############################################################
# Can set srand from the environment.
PERL_RAND_SEED=123 perl -E 'say srand; say rand; say srand'
123
0.279512001973675
31682556
#############################################################
## Perl Functions - state
#############################################################
# Perl Functions - state
# Both ways work. 2nd seems messy.
perl -E 'sub id { state $v = 100; ++$v } say id for 1..5'101
perl -E 'sub id { BEGIN{ my $v = 100; sub up { $v++ } } up() } say id() for 1..5'
100
101
102
103
104
#############################################################
## Perl Funtions - substr
#############################################################
# substr can be used in a for loop to change just the field.
perl -E 'my $v = "1234"; for(substr $v, 1, 2){ $_ = "dog" } say $v'
1dog4
#############################################################
## Perl Functions - sysread
#############################################################
# Read 10 characters of input (Perl Functions - sysread).
perl -E 'my $in; my $len = sysread STDIN, $in, 10 or exit; say "[$in]"'
123456789012345678901234567890[1234567890]
#############################################################
## Perl Functions - system
#############################################################
# Using bash inside of a perl system call (plus source)
# Source some reason is NOT recursive!
system (
# Start at character 3 (0-based)
# Pull out the next 8 bits
perl -le 'print chr vec "Just another Perl hacker", 3,8'
#############################################################
## Perl Functions - wantarray
#############################################################
# Check context of Perl subroutine return type
perl -E 'sub func{ $w=wantarray; say $w ? "LIST" : defined $w ? "SCALAR" : "VOID" } $h={key => func()}; $h={key => scalar func()}'
# Scalar versus list context
perl -Mojo -E 'sub func{ return } my @array = func(); say r \@array; my $scalar = func(); say r $scalar; sub func2 { say r \@_ } func2( func(), "Test was ok" ); func2( scalar func(), "Test was ok" )'
#############################################################
## Perl Operators - Decrement (--)
#############################################################
# Magic decrement operator in perl
perl -le "$_='perl'; package Mag; use strict; use warnings; use vars qw/$q/; BEGIN{$q=chr 34} use overload q(--) => \&dec, qq($q$q) => sub{ ${ $_[0] } }; sub new { my($c,$v) = @_; bless \$v, $c } sub dec { my @s=reverse split //, $_[0]; my $i; for($i...
# Grab stuff between spots (range operator)
cat alpha.dat | perl -ne 'print if /U N I G R A P H/ ... /TOTAL/i'
# Extract lines between the START and END markers (exclusively) (range operator)
cat file | perl -nle '$a=/START/.../END/; print if $a and $a!=1 and $a!~/E0$/'
# Range operator bug:
#
# Each flip flop maintains a global state:
perl -E 'sub f{ local $_ = shift; my $r = /a/ ... /b/; say $r } f $_ for qw/ a a /'
#
# Make a generator with with a closure and use a reference to a state variable.
perl -E 'sub f{ state $n=0; $n++; sub{ 0+$n; local $_ = shift; my $v = /a/ ... /b/; say $v } } $f1 = f; $f1->("a"); $f2 = f; $f2->("a")'
#
# Can see each sub point now to a different code ref.
perl -MDevel::Peek -E 'sub f{ state $n=0; $n++; sub{ 0+$n; local $_ = shift; my $v = /a/ ... /b/; say $v } } $f1 = f; $f1->("a"); $f2 = f; $f2->("a"); say Dump $_ for $f1, $f2'
#############################################################
## Perl Variable Types
#############################################################
# Using "our" declaration in perl
#
# ok
perl -le "INIT{ $STOP=3 }; print $STOP"
# fix3: Full package name
perl -le "use strict; INIT{ $main::STOP=3 } print $main::STOP"
perl -le "use strict; INIT{ $::STOP=3 } print $::STOP"
#############################################################
## Perl Variables - General
#############################################################
# Effective UID of current perl program
perl -lE 'say $>'
# Real UID of current perl program
perl -lE 'say $<'
# Effective GID of current perl program
perl -lE 'say $)'
# Real GID of current perl program
perl -lE 'say $('
# Perl print all the special "$^X" variables
perl -le "print qq($_ = ), eval for map(qq(\$^$_), A..Z)"
# Produce "is not available at" warning.
perl -E 'use warnings; { my $v = 123; sub run { say eval q($v) } } run(q($v))'
#############################################################
## Perl Variables - $@
#############################################################
# Successful eval will reset $@.
perl -E 'eval{1/0}; say $@; eval{}; say $@'
#############################################################
## Perl Variables - ${^GLOBAL_PHASE}
#############################################################
# Perl Variables - ${^GLOBAL_PHASE} - Can check if in DESTROY.
perl -E 'package P; sub DESTROY { say ${^GLOBAL_PHASE} } { my $v = bless {}, "P" }'
RUN
#############################################################
## Perl Variables - @{^CAPTURE}
#############################################################
# Get a list of all matches.
# Available from v5.26
perl -E '"abc" =~ /(.)(.)(.)/; say for $1,$2,$3'
perl -E '"abc" =~ /(.)(.)(.)/; say for @{^CAPTURE}'
a
b
c
perl -E '"abc" =~ /(.)(.)(.)/; say for ${^CAPTURE[0]}'
a
# Before @{^CAPTURE}:
perl -E '"abc" =~ /(?<a>.)(?<b>.)(?<c>.)/; say for sort keys %+'
a
b
c
perl -E '"abc" =~ /(?<v>.)(?<v>.)(?<v>.)/; say for $-{v}->@*'
a
b
c
#############################################################
## Perl Variables - %INC
#############################################################
# Find Perl library
called with the filename form of the item being
loaded. The hook may modify $_[0] to load a
different filename, or it may throw a fatal
exception to cause the require to fail, which
will be treated as though the required code
itself had thrown an exception.
perl -E '
use warnings;
BEGIN{
${^HOOK}{require__before} = sub {
say "here: @_";
$_[0] =~ s/Scalar/List/;
};
}
use Scalar::Util qw( reftype );
my $v = [];
say reftype $v
'
here: Scalar/Util.pm
here: strict.pm
here: warnings.pm
here: strict.pm
here: Exporter.pm
here: strict.pm
here: strict.pm
here: XSLoader.pm
here: strict.pm
here: strict.pm
Unquoted string "reftype" may clash with future reserved word at -e line 1.
Name "main::reftype" used only once: possible typo at -e line 1.
say() on unopened filehandle reftype at -e line 1.
# Perl Variables - %{^HOOK}
As of 5.37.10,
There is a similar hook that fires after require
completes, ${^HOOK}{require__after}, which will
be called after each require statement completes,
either via an exception or successfully. It will
be called with the filename of the most recently
executed require statement. It is executed in an
eval, and will not in any way affect execution.
undef - slurp mode
blank - paragraph mode
\256 - fixed byte mode
#############################################################
## Perl Variables - *STDOUT
#############################################################
# Redirect STDOUT to a variable in perl
perl -E "{local *STDOUT; open STDOUT, '>', \$v or die $!; say 123;} say qq([$v])"
# Use -t to test STDIN and STDOUT:
sub I_am_interactive {
return -t STDIN && -t STDOUT;
}
#############################################################
## Perl Variables - $^T
#############################################################
In My.pmc
#############################################################
## Perl Modules - AnyEvent
#############################################################
# Simple exmplae of parallel processing
# (Perl Modules - AnyEvent)
# NOT WORKING!
perl -MAnyEvent -E 'my @files = (1..30); my $cv = AnyEvent->condvar; foreach my $file (@files) { $cv->begin; AnyEvent->timer(after => 0, cb => sub { say "Processing file $file"; sleep(1); $cv->end; }); } $cv->recv;'
#############################################################
## Perl Modules - Automake::Config
#############################################################
# Install Automake::Config (termux)
git clone git@github.com:poti1/arm-none-eabi.git
cd arm-none-eabi
cpanm --look automake-1.15.gz
$ ./configure
$ make
$ make install
#############################################################
## Perl Modules - autovivification
#############################################################
# autovivification Example:
perl -Me -E 'my $h = { k => 11 }; no autovivification; say defined $h->{k2}{k3}{k5}; p $h'
{
k 11
}
#############################################################
## Perl Modules - B::Concise
#############################################################
# Perl Modules - B::Concise
#############################################################
## Perl Modules - binmode
#############################################################
# Using unicode in perl STDOUT
perl -CO script
perl -C script # Which is same as
perl -CDSL script # S includes I/O
perl -e 'binmode STDOUT, "encoding(UTF-8)"'
perl -e 'binmode STDOUT, ":utf8"'
perl -E 'use open qw/:std :utf8/; say "\N{SNOWFLAKE}"'
# Mixed up encoding.
perl -E '$s = "é"; say length($s) . " $s"'
2 é
perl -C -E '$s = "é"; say length($s) . " $s"'
2 é
perl -Mutf8 -E '$s = "é"; say length($s) . " $s"'
1 �
perl -C -Mutf8 -E '$s = "é"; say length($s) . " $s"'
1 é
#############################################################
## Perl Modules - Business::CreditCard
#############################################################
# Validate a credit card number.
perl -MBusiness::CreditCard -E 'say validate("5276 4400 6542 1319")'
1
#
perl -MBusiness::CreditCard -E 'say cardtype("5276 4400 6542 1319")'
MasterCard
#############################################################
## Perl Modules - charnames
#############################################################
# Convert between a Unicode character, hexidecimal number and the name
perl -CDAS -E 'use charnames(); printf "%s %#x %s\n", $_, ord, charnames::viacode(ord) for @ARGV' ℠☃
# â„ 0x2744 SNOWFLAKE
# ☃ 0x2603 SNOWMAN
# Converting between a Unicode name, code, and string
# Name: SNOWFLAKE
# Code: 0x2744, 10052
# String: \N{SNOWFLAKE}, \N{U+2744}, \x{2744}, â„
#
perl -C -E 'say "\N{SNOWFLAKE}"' # \N{SNOWFLAKE} -> â„
perl -C -E 'say "\N{U+2744}"' # \N{U+2744} -> â„
perl -C -E 'say "\x{2744}"' # \x{2744} -> â„
perl -C -Mutf8 -E 'say "â„"' # â„ -> â„
perl -E 'say "â„"' # â„ -> â„
perl -E 'use open qw/:std :utf8/; say "\N{SNOWFLAKE}"' # \N{SNOWFLAKE} -> â„
#
perl -Mutf8 -E 'printf "%#x\n", ord "â„"' # â„ -> 0x2744
perl -Mutf8 -E 'say ord "â„"' # â„ -> 10052
perl -Mutf8 -Mcharnames=:full -E 'say charnames::viacode ord "â„"' # â„ -> SNOWFLAKE
#
perl -C -Mcharnames=:full -E 'say charnames::vianame("SNOWFLAKE")' # SNOWFLAKE -> 2744
perl -C -Mcharnames=:full -E 'printf "%#x\n", charnames::vianame("SNOWFLAKE")' # SNOWFLAKE -> 0x2744
perl -C -Mcharnames=:full -E 'say charnames::string_vianame("SNOWFLAKE")' # SNOWFLAKE -> â„
#
perl -C -Mcharnames=:full -E 'say charnames::viacode("U+2744")' # U+2744 -> SNOWFLAKE
perl -C -Mcharnames=:full -E 'say charnames::viacode(0x2744)' # 0x2744 -> SNOWFLAKE
perl -C -Mcharnames=:full -E 'say charnames::viacode("10052")' # 10052 -> SNOWFLAKE
# Difference between the different whitespace regex characters
perl -Mcharnames=:full -E 'my @qr = (qr/\s/, qr/\h/, qr/\v/, qr/[[:space:]]/, qr/\p{Space}/); my $fmt = "%#06x" . ("%2s" x @qr) . " %s\n"; printf "\nVersion: $^V\n$fmt\n", qw/- s h v p u Name/; for my $ord (0..0x10ffff){ my $chr = chr $ord; next unle...
#
# s - \s
# v - \v
# p - [[:space:]] (POSIX)
# u - \p{Space}
# Version: v5.32.1
# 000000 s h v p u Name
#
# 0x0009 x x x x CHARACTER TABULATION
# 0x000a x x x x LINE FEED
# Last unicode character
0x10FFFF
#############################################################
## Perl Modules - constant
#############################################################
# Create a constant in perl.
perl -E 'use constant ABC => 123; say ABC' 123
perl -Mconstant=ABC,123 -E 'say ABC' 123
perl -E 'sub ABC(){ 123 } say ABC' 123
perl -E 'sub ABC{ 123 } say ABC' 123
#############################################################
## Perl Modules - cpanm
#############################################################
# Install cpanm
cpan App::cpanminus
# Install dependencies using cpanm
# Debug a regular expression
perl -Mre=debug -le 'print "abc:def-hij"=~/\w+/'
perl -Mre=debug -e 'print if "aaa:bbb" =~ /\w+/'
perl -Mre=Debug,PARSE -e 'print if "aaa:bbb" =~ /\w+/'
# Debug a regular expression (with some color)
perl -Mre=debugcolor -le 'print "abc:def-hij"=~/\w+/'
# Check if certain words are in order in a file
echo "line1 line2" | perl -0777nlE 'INIT{-t and die; $a=join".*?",map{/\S+/g}<STDIN>; $r=qr/$a/s} say "$ARGV - " . (/$r/?"PASS":"FAIL") ' f1 f2
echo "line1 line4" | perl -Mre=eval -0777ne 'INIT{-t and die; $a=join "",map qq[ (?{print"\\nTrying $_ - "}) (.*?(??{"$_"}) (?{print"pass"})) ],map{/\S+/g}<STDIN>; $r=qr/^$a/sx; print "\n\$r=qr$r\n\n"} print "\n# $ARGV"; print "\n".(/$r/?"PASS":"FAIL...
echo "line1 line4" | perl -Mre=eval -0777ne 'INIT{-t and die; $a=join "",map qq[ (?{print"\\nTrying $_ - "}) (.*?(??{"$_"}) (?{print"pass"})) ],map{/\S+/g}<STDIN>; $r=qr/^$a/sx} print "\n# $ARGV"; print "\n".(/$r/?"PASS":"FAIL")."\n\n"' f1 f2
# View optimizations done on a pattern.
perl -Mre=optimization -Mojo -E 'say r optimization qr/^abc/'
# A way to check if using a regular expression.
perl -Mre=is_regexp -E 'say is_regexp qr{}'
1
perl -Mre=is_regexp -E 'say is_regexp 123'
#############################################################
## Perl Modules - threads
#############################################################
# Error: This Perl not built to support threads
# Check if perl binary supports threads.
perl -V:useithreads
perl -MConfig -E 'say $Config{useithreads}'
# Simple thread example in perl
# Threads start running already with threads->create()
perl -Mthreads -le '@t=map threads->create(sub{print "Im #$_"}), 1..10; $_->join for @t'
# Simple thread example in perl
# Find the summation of 1 through 10
# Uses a shared variable between threads
perl -Mthreads -Mthreads::shared -le '$sum=0; share($sum); @t=map threads->create(sub{$sum += $_}), 1..10; print $_->join for @t; print "sum: $sum"'
#############################################################
## Perl Modules - CAM::PDF
#############################################################
# Example getting title fields from a pdf.
use CAM::PDF;
use e;
my $infile = shift or die "\nSyntax: perl fill:pdf.pl my.pdf\n";
(my $outfile = $infile) =~ s/(?=\.pdf)/_filled/i;
my $doc = CAM::PDF->new($infile) or die "$CAM::PDF::errstr\n";
say "Titles of the fields:";
p [$doc->getFormFieldList];
say "Adding new field values";
$doc->fillFormFields(
Start_Date => "Value 1",
Closed_Date => "Value 2",
Closed_By => "Value 3",
);
say "saving new file";
$doc->cleanoutput($outfile);
#############################################################
## Perl Modules - Carp
#############################################################
# Show a stack trace in perl.
perl -MCarp=longmess -E 'sub fun1{ fun2("TO FUN2") } sub fun2{ say longmess } fun1("TO FUN1")'
# Show a stack trace in perl. (Carp uses a similar approach).
# @DB::args is set (for a scope) when this command is run (some magic).
{
package DB;
my @caller = caller($scope);
() = caller($scope); # Same thing (to invoke LIST context).
}
perl -E 'sub fun1{ fun2("TO FUN2") } sub fun2{ my $scope = 0; while(my @caller = caller($scope)){ {package DB; () = caller($scope)} say "@caller[1,2,3,4] - (@DB::args)"; $scope++ }} fun1("TO FUN1")'
#############################################################
## Perl Modules - Carton
#############################################################
# Keep track of the installed modules in a local directory by making a
# virtual environment. Like virtualenv and requirements.txt, but for Perl.
cpanm Carton
# Generate a sample html page
perl -MCGI=:standard,:html3 -le 'print header(),start_html(),ol(li [qw/red blue green/]),end_html()' > my.html
perl -MCGI=:standard,:html3 -le 'print header(),start_html(),td(Tr [qw/red blue green/]),end_html()' > my2.html
#############################################################
## Perl Modules - Class::Tiny
#############################################################
# Alternate to Mojo::Base has.
perl -Mojo -E '{ package A; use Class::Tiny qw(name age color); sub new { bless {}, shift } } my $obj = A->new; $obj->name("bob"); $obj->color("blue"); say r $obj'
bless( {
"color" => "blue",
"name" => "bob"
}, 'A' )
#############################################################
## Perl Modules - Crypt::JWT
#############################################################
# Example of encoding using JWT.
perl -MCrypt::JWT=encode_jwt -E '$token = encode_jwt(payload=> "hello jwt", alg=>"HS256", key=>"mypass"); say $token'
eyJhbGciOiJIUzI1NiJ9.aGVsbG8gand0.UMNFghYANKBBnAbLgTVe26QEyPFLwPMbb7piDSRYNBQ
# Example of decoding using JWT.
perl -MCrypt::JWT=encode_jwt,decode_jwt -E '$token = encode_jwt(payload=> "hello jwt", alg=>"HS256", key=>"mypass"); say decode_jwt(token => $token, key => "mypass" )'
HMAC Integrity check
- key: [mypass]
$X4]hmac: [PÃE4 AË5^Û¤ÈñKÀóºb
hello jwt
#############################################################
## Perl Modules - Crypt::PasswdMD5
#############################################################
# Generate MD5 Password
perl -MCrypt::PasswdMD5 -lE 'say unix_md5_crypt('pass','salt')'
openssl passwd -1 -salt salt pass
#############################################################
## Perl Modules - Cwd
#############################################################
# Get current working directory (slightly different than pwd)
perl -MCwd -le 'print getcwd'
# Get absolute path to a file (works same for link and regular files,DES)
perl -MCwd=realpath -le '$_="file"; print realpath($_)'
#############################################################
## Perl Modules - DateTime
#############################################################
# Create expiration dates (Start of tomorrow,start of next week)
perl -MDateTime -E '$dt = DateTime->now; say $dt->add(days => 1)->truncate(to => "day" )'
# 2021-08-06T00:00:00
perl -MDateTime -E '$dt = DateTime->now; say $dt->add(weeks => 1)->truncate(to => "local_week" )'
# 2021-08-08T00:00:00
# Truncate date to start of this week (Monday).
perl -MDateTime -E '$dt = DateTime->now; say $dt->truncate(to => "week" )->strftime("%e %b %Y")'
# Truncate date to end of 3 weeks from now on a Friday.
perl -MDateTime -E '$dt = DateTime->now; say $dt->truncate(to => "week" )->add(weeks => 3, days => 4)->strftime("%e %b %Y")'
#############################################################
## Perl Modules - Data::DPath
#############################################################
# Recurse through a data structure and print matches.
perl -MData::DPath -Mojo -E 'my $data = {a => [0, {complex => 1}]}; say "\nBefore:"; say r $data; for my $node ( grep {ref} Data::DPath->match($data, "//") ){ say "Tying: $node: " . r $node}'
#
# Before:
# {
# "a" => [
# 0,
# {
# "complex" => 1
# }
# ]
# }
# Tying: HASH(0xb400007e988291f0): {
# "a" => [
# 0,
# {
# "complex" => 1
# }
# ]
# }
# Show where a complex data structure is being updated.
perl -MData::DPath -MCarp=longmess -MTie::Watch -Mojo -E 'my $data = {a => [0, {complex => 1}]}; say "\nBefore:"; say r $data; for my $node ( grep {ref} Data::DPath->match($data, "//") ){ say "Tying: $node"; Tie::Watch->new( -variable => $node, -stor...
#############################################################
## Perl Modules - Data::Dumper
#############################################################
# Deparse a subroutine in a data structure
perl -MData::Dumper -le '$ref=sub{print "in sub"}; &$ref; my $d=Data::Dumper->new([$ref])->Deparse(1); print $d->Dump'
# Deparse/show the code of a subroutine
sub _dumper {
require Data::Dumper;
my $data = Data::Dumper
->new( [@_] )
->Indent( 1 )
->Sortkeys( 1 )
->Terse( 1 )
->Useqq( 1 )
->Dump;
return $data if defined wantarray;
say $data;
}
#############################################################
## Perl Modules - Data::Printer
#############################################################
# Colorful data dumper.
# p - print.
# np - capture dump output.
[4] 123
]
#############################################################
## Perl Modules - Data::Trace
#############################################################
# Show where a complex data structure is being updated.
cpanm Data::Trace
perl -MData::Trace -Mojo -E 'my $data = {a => [0, {complex => 1}]}; say "\nBefore:"; say r $data; Data::Trace->Trace($data); sub BadCall{ $data->{a}[0] = 1 } say ""; BadCall(); say "After:"; say r $data'
# Data::Trace (WIP).
perl -Me -MData::Trace -E 'get("Kernel::System::Cache")->Set( Type => "Ticket", Key => "ABC", Value => [1..3] ); Data::Trace->Trace( get("Kernel::System::Cache") ); get("Kernel::System::Cache")->Delete( Type => "Ticket", Key => "ABC" )'
#############################################################
## Perl Modules - DBD::mysql
#############################################################
# Bug in DBD::mysql before version 5.007:
#
cpanm DBD::mysql@5.006
perl -Me2 -e '$d = get("Kernel::System::DB"); $d->Connect; $d->Disconnect; $d->Connect; say "END"'
ConnectCached
Disconnect
ConnectCached
Segmentation fault (core dumped)
#
cpanm DBD::mysql@5.007
perl -Me2 -e '$d = get("Kernel::System::DB"); $d->Connect; $d->Disconnect; $d->Connect; say "END"'
ConnectCached
Disconnect
ConnectCached
END
#############################################################
## Perl Modules - DBI
#############################################################
# How to connect to database using perl DBI (postgres,sample,sql)
perl -MDBI -E '$dbh = DBI->connect("DBI:Pg:dbname=$db; host=127.0.0.1", "$user", "$pass", {RaiseError => 1}) or die $DBI::errstr; say "\nOpened db successfully!\n"'
# How to query information from a database using perl (postgres,sample,sql)
perl -MDBI -E 'sub Die { die $DBI::errstr } $dbh = DBI->connect("DBI:Pg:$db=srto_8_0; host=127.0.0.1", "$user", "$pass", {RaiseError => 1}) or Die; $sth = $dbh->prepare(q(SELECT * from MyTable;)) or Die; $sth->execute() or Die; while(@row = $sth->fet...
# Fetchbdata from SQLite database.
perl -MDBI -E 'my $dbh = DBI->connect("DBI:SQLite:kjv.bbl.mybible", '', '', {RaiseError => 1}); my $sth = $dbh->prepare("select * from Bible limit 3"); $sth->execute; while(my @row = $sth->fetchrow_array ){ say "@row" } $dbh->disconnect'
perl -MDBI -E 'my $dbh = DBI->connect("DBI:SQLite:kjv.bbl.mybible", '', '', {RaiseError => 1}); my $all = $dbh->selectall_arrayref("select * from Bible limit 3"); for my $row ( @$all ){ say "@$row" } $dbh->disconnect'
perl -MDBI -E 'my $dbh = DBI->connect("DBI:SQLite:kjv.bbl.mybible", '', '', {RaiseError => 1}); for my $row ( $dbh->selectall_array("select * from Bible limit 3") ){ say "@$row" } $dbh->disconnect'
# View install drivers for DBI.
perl -MDBI -E 'say for DBI::available_drivers'
# Example using selectrow_hashref.
perl -MData::Printer -MDBI -E 'my $t=shift; my $d = DBI->connect("DBI:SQLite:$t"); my $r = $d->selectrow_hashref("select * from details"); p $r' $t
#############################################################
## Perl Modules - DBI::Profile
#############################################################
# Profile SQL statements in perl DBI.
#############################################################
## Perl Modules - Devel::Peek
#############################################################
# Examine a data structure of variables in C code
perl -MDevel::Peek -le '$a=15; print Dump($a)'
# Capture Devel::Peek::Dump output to a file.
perl -MDevel::Peek -E 'open my $fd2, ">&=STDERR"; open $fd2, ">", "out.txt"; say fileno($fd2); Dump(undef)'
#
# This would change fd to 3 (Does NOT work!)
perl -MDevel::Peek -E 'open my $fd2, ">&=STDERR"; close $fd2; open $fd2, ">", "out.txt"; say fileno($fd2); Dump(undef)'
# Capture Devel::Peek::Dump output to a variable.
# This one does NOT work!
perl -MDevel::Peek -E 'open my $fd2, ">&=STDERR"; open $fd2, ">", \$var; say fileno($fd2); Dump(undef); close $fd2; say "[$var]"'
#
# This would change fd to -1 (Does NOT work!)
perl -MDevel::Peek -E 'open my $fd2, ">&=STDERR"; close $fd2; open $fd2, ">", \$var; say fileno($fd2); Dump(undef); close $fd2; say "[$var]"'
#
# This uses a tempfile (WORKS!)
# (Dump disables autoflush. need to close the file.)
perl -Mstrict -Mwarnings -MDevel::Peek -MFile::Temp -E 'my $tmp = File::Temp->new; open my $fh, ">&=STDERR"; open $fh, ">", "$tmp"; say fileno($fh); Dump(undef); say $fh 123; close $fh; open $fh, "<", "$tmp" or die $!; while(<$fh>){chomp; say "[$_]"}...
#############################################################
## Perl Modules - Devel::REPL
#############################################################
# Using a read,evaluate,print,loop in perl.
perl -MDevel::REPL -E '
my $my_var = 111;
our $our_var = 222;
);
$repl->run;
'
#############################################################
## Perl Modules - Devel::Size
#############################################################
# Find out the size of variables.
use Devel::Size qw( total_size );
say "size: " . total_size($bytes);
#############################################################
## Perl Modules - Email::Address::XS
#############################################################
# Example of using Email::Address::XS
perl -Mojo -MEmail::Address::XS -E 'say r $_ for Email::Address::XS->parse("First Last email\@localhost")'
bless( {
"comment" => undef,
"host" => undef,
"invalid" => 1,
"original" => "First ",
"phrase" => undef,
"user" => "First"
}, 'Email::Address::XS' )
#############################################################
## Perl Modules - Encode
#############################################################
# Example of using Encode to show string in different supported encodings (broken).
perl -C -MEncode -E '$s1="Ue: Ü"; $s2="Euro: \N{EURO SIGN}"; for ( encodings ) { printf "%-15s: [%-7s] [%s]\n", $_, encode($_,$s1), encode($_,$s2) }'
# Why use Encode?
perl -E 'say "\xe1"' # �
perl -C -E 'say "\xe1"' # á
perl -MEncode -E 'say encode "UTF-8", "\xe1"' # á
perl -MEncode -E 'use open ":std", ":encoding(UTF-8)"; say "\xe1"' # á
perl -MEncode -E 'use open qw(:std :utf8); say "\xe1"' # á
# Mixed up encoding.
perl -MEncode -E '$s = encode("UTF-8","é", Encode::FB_CROAK|Encode::LEAVE_SRC); say length($s) . " $s"'
4 é
perl -C -MEncode -E '$s = encode("UTF-8","é", Encode::FB_CROAK|Encode::LEAVE_SRC); say length($s) . " $s"'
4 é
perl -Mutf8 -MEncode -E '$s = encode("UTF-8","é", Encode::FB_CROAK|Encode::LEAVE_SRC); say length($s) . " $s"'
2 é
perl -C -Mutf8 -MEncode -E '$s = encode("UTF-8","é", Encode::FB_CROAK|Encode::LEAVE_SRC); say length($s) . " $s"'
2 é
# Decoding example.
perl -C -MEncode -E 'say decode("UTF-8", chr(0xc3).chr(0xa9), Encode::FB_CROAK)'
é
#############################################################
## Perl Modules - Excel::Writer::XLSX
#############################################################
# Excel - Simple: Generate a blank xlsx file
perl -MExcel::Writer::XLSX -E "$wb = Excel::Writer::XLSX->new('my.xlsx'); $wb->close"
## Perl Modules - File::Find
#############################################################
# find2perl.pl script.
use File::Find;
use e;
our ($name);
*name = *File::Find::name;
*find = *File::Find::find;
find( {
wanted => sub { say $name if /tri/ },
},
'.'
);
#############################################################
## Perl Modules - File::Tee
#############################################################
# Writing to multiple filehandles
## Perl Modules - Hook::LexWrap
#############################################################
# Wrap a subroutine and see the input and output
perl -MHook::LexWrap -le 'wrap 'abc', pre => sub{print "pre: [@_[0..$#_-1]]"}, post => sub{print "post: [@{$_[-1]}]"}; sub abc{my($a,$b)=@_; $a+$b} print abc 2,3'
# Wrap a subroutine and see the input and output. modify results
perl -MHook::LexWrap -le 'wrap 'abc', post => sub{$_[-1] = 8}; sub abc{my($a,$b)=@_; $a+$b} print abc 2,3'
# Wrap and unwrap all class functions. (idea)
perl -MModule::Functions=get_full_functions -MHook::LexWrap -MB -E '$class = "MyClass"; my @unwrap = map wrap($_, pre => sub{ my @c=caller; say "[@c] " . B::svref_2object(__SUB__)->GV->NAME; my @c2 = CORE::caller; say "@c"; }), sort {$a cmp $b} map {...
#############################################################
## Perl Modules - HTML::Tree
#############################################################
# Reduce Data::Dumper to the first layer of depth
perl -MHTML::Tree -MData::Dumper -le 'sub pr{my $d=Data::Dumper->new(\@_)->Sortkeys(1)->Terse(1)->Indent(1)->Maxdepth(1); print $d->Dump} $t=HTML::Tree->new_from_file("rakudo2.html"); $f=$t->look_down(qw/_tag td/); pr $_ for $f'
# Extract text from HTML
use Inline "C";
use Inline "NOCLEAN"; # Keep build library.
print triple(5);
__END__
__C__
int triple(int num) {
return num * 3;
}
# Inline::C oneliner
perl -MInline='C,int triple(int num){ return num * 3; }' -E 'say triple 4'
# Inline::C oneliner (Keep build library)
perl -MInline=NOCLEAN -MInline='C,int triple(int num){ return num * 3; }' -E 'say triple 4'
#############################################################
## Perl Modules - IO::Select
#############################################################
# Simple example of Perl Modules - IO::Select
perl -MIO::Select -E 'say *STDOUT; say fileno(*STDOUT); my $s = IO::Select->new( \*STDIN ); say $s->can_read(0.5)'
*main::STDOUT
1
#############################################################
## Perl Modules - IO::Socket::INET
#############################################################
# Simple perl client using IO::Socket::INET.
use IO::Socket::INET;
#############################################################
## Perl Modules - IPC::Open2, IPC::Open3
#############################################################
# Simple example of capturing STDOUT and STDERR separately in perl.
perl -MSymbol=gensym -MIPC::Open3 -E 'my $pid = open3( my $in_fh, my $out_fh, my $err_fh = gensym(), "echo OUT; echo ERR >&2" ); while(<$err_fh>){ chomp; say}'
#
# STDERR goes to the same place.
perl -MIPC::Open3 -E '$pid = open3( $in_fh, $out_fh, ">&STDERR", "echo OUT; echo ERR >&2; exit 123" ); waitpid( $pid, 0 ); my $error = $? >> 8; say "error=$error"; if($error){ while(<$out_fh>){ print } }'
perl -MIPC::Open2 -E '$pid = open2( $out_fh, $in_fh, "echo OUT; echo ERR >&2; exit 1" ); waitpid( $pid, 0 ); my $error = $? >> 8; say "error=$error"; if($error){ while(<$out_fh>){ print } }'
# IPC::Open3 Bug?!
perl -MFile::Temp=tempfile -MIPC::Open3 -E '($fh,$file)=tempfile(); print $fh "1234567890"x10000; close $fh; $pid = open3( $in_fh, $out_fh, ">&STDERR", "cat $file" ); waitpid( $pid, 0 ); say "DONE $file"'
#############################################################
## Perl Modules - IPC::SysV
#############################################################
# Create a new SysV IPC stream
perl -MIPC::SysV=IPC_PRIVATE,IPC_CREAT,S_IRUSR,S_IWUSR -le 'print msgget(IPC_PRIVATE, IPC_CREAT | S_IRUSR | S_IWUSR)'
print My::reduce {$_[0] + $_[1]} 1..10;
__END__
55
#############################################################
## Perl Modules - Locale::Country
#############################################################
# Build key value lookup table of all country codes.
perl -MLocale::Country -E 'say uc "$_: " . code2country($_) for all_country_codes'
#############################################################
## Perl Modules - Lock::File
#############################################################
# Simple module for locking a file. (exclusive,shared)
perl -MLock::File=lockfile -E 'my $lock = lockfile("my.lock7") or die $!; sleep 100000'
perl -MLock::File=lockfile -E 'my $lock = lockfile("my.lock7", {shared => 1}) or die $!; sleep 100000'
# Get http request. practice using LWP::UserAgent
perl -MLWP::UserAgent -MData::Dumper -le '$u="http://www.google.com"; $ua=LWP::UserAgent->new; $ua->env_proxy; $r=$ua->get($u); print $r->header("Server")'
#############################################################
## Perl Modules - Mail::Address
#############################################################
# Example of using Mail::Address.
perl -Mojo -MMail::Address -E 'say r $_ for Mail::Address->parse("First Last email\@localhost")'
bless( [
"",
"First",
""
], 'Mail::Address' )
bless( [
"",
"Last",
""
"email\@localhost",
""
], 'Mail::Address' )
#############################################################
## Perl Modules - Math::Combinatorics
#############################################################
# Get permutations of lists (make a table).
perl -lE '$_="{0,1}"x3; say for glob'
perl -E 'say for glob "{A,B}{1,2}"'
perl -lE 'say for glob "{0,1}{0,1}{0,1}{0,1}"'
perl -MMath::Combinatorics=permute -lE 'say for map{"@$_"} permute(qw/a b c/)'
#############################################################
## Perl Modules - Math::Expression
#############################################################
# Perl Modules - Math::Expression example
perl -MMath::Expression -E 'my $m = Math::Expression->new; say $m->ParseToScalar("Dog := 4; Chicken := 2; Dog + Chicken")'
6
# 0,5 versus 0.5 in a math expression.
perl -MMath::Expression -Mojo -E 'my $m = Math::Expression->new; my $tree = $m->Parse("0,5 - 5"); say r $tree'
{
"after" => 1,
"left" => {
"oper" => "const",
"type" => "num",
"val" => 0
},
"oper" => ",",
"right" => {
"after" => 1,
},
"oper" => "-",
"right" => {
"oper" => "const",
"type" => "num",
"val" => 5
}
}
}
tim@timPC ~ ➜ perl -MMath::Expression -Mojo -E 'my $m = Math::Expression->new; my $tree = $m->Parse("0.5 - 5"); say r $tree'
{
"after" => 1,
"left" => {
"oper" => "const",
"type" => "num",
"val" => "0.5"
},
"oper" => "-",
"right" => {
"oper" => "const",
"val" => 5
}
}
#############################################################
## Perl Modules - Math::Factoring
#############################################################
# Factoring a number to get the prime numbers
perl -MMath::Factoring=factor -E "say for factor 666"
#############################################################
## Perl Modules - Memoize
#############################################################
# In-Memory storage/cache using Memoize.
# Output depends entirely on input args.
perl -Me -e '
package Other;
use e;
sub Add {
trace();
my ($num1,$num2) = @_;
return $num1 + $num2;
}
package main;
use Memoize;
memoize("Other::Add");
say(Other::Add(2,3)) for 1..3;
'
[2024/05/10-10:22:08.164] --> [2] Add ...
5
5
5
# In-Memory storage/cache using Memoize.
# Normalize if the output is not enturely dependent upon
# the input (something found in $self)
perl -Me -e '
package main;
use Memoize;
memoize(
"Other::Add",
NORMALIZER => sub {
my ($self,$num) = @_;
join "::", $self->{num}, $num;
}
);
my $obj = bless { num => 2 }, "Other";
say($obj->Add(3)) for 1..3;
$obj->{num} = 4;
say($obj->Add(3)) for 1..3;
'
[2024/05/10-10:22:08.164] --> [2] Add ...
5
5
5
[2024/05/10-10:22:08.175] --> [2] Add ...
7
7
7
#############################################################
# Persistent cache using Memoize::Storable
#############################################################
## Perl Modules - Modern::Perl
#############################################################
# Modern::Perl defaults to v5.12 (bug!?)
perl -E 'say $^V'
v5.36.0
perl -Modern::Perl -e 'say Modern::Perl::validate_date(2022)'
:5.34
perl -Modern::Perl -e 'say Modern::Perl::validate_date()'
:5.12
perl -E 'sub abc ($n) {$n}'
perl -Modern::Perl=2022 -e 'sub abc ($n) {$n}'
perl -Modern::Perl -e 'sub abc ($n) {$n}'
Illegal character in prototype for main::abc : $n at -e line 1.
Global symbol "$n" requires explicit package name (did you forget to declare "my $n"?) at -e line 1.
Execution of -e aborted due to compilation errors.
#############################################################
#
#!/usr/bin/env perl
package My;
use strict;
use warnings;
use parent qw( Exporter );
our @EXPORT = qw( Run );
sub Run { print "111\n" }
1;
#
perl -I. -MModule::Refresh -E 'use My; Run(); say qq(before: $INC{"My.pm"}); Module::Refresh->refresh_module("My.pm"); say qq(after: $INC{"My.pm"}); Run()'
111
before: My.pm
after: My.pm
Undefined subroutine called at -e line 1.
# Cannot undef, delete, and require a subroutine.
# My.pm:
package My;
sub Run { print "111\n" }
1;
monkey_patch $caller,
a => sub { $caller->can('any')->(@_) and return $ua->server->app },
b => \&b,
c => \&c,
d => sub { $ua->delete(@_)->result },
f => \&path,
g => sub { $ua->get(@_)->result },
h => sub { $ua->head(@_)->result },
j => \&j,
l => sub { Mojo::URL->new(@_) },
n => sub (&@) { say STDERR timestr timeit($_[1] // 1, $_[0]) },
o => sub { $ua->options(@_)->result },
p => sub { $ua->post(@_)->result },
r => \&dumper,
t => sub { $ua->patch(@_)->result },
u => sub { $ua->put(@_)->result },
x => sub { Mojo::DOM->new(@_) };
}
# Download a PDF file using Perl
# Will not download if it is already up to date. (by etag)
perl -Mojo -E "my $q=chr 34; sub get_etag($tx){ $tx->result->headers->etag =~ s/^$q|$q$//gr; } my $ua = Mojo::UserAgent->new; my $url = Mojo::URL->new('https://hop.perl.plover.com/book/pdf/HigherOrderPerl.pdf'); my $f = $url->path->parts->[-1]; my $t...
# Fetch latest unicode characters (Windows)
perl -CSAD -Mojo -mcharnames -E "my $ua = Mojo::UserAgent->new; my $url = 'https://blog.emojipedia.org/whats-new-in-unicode-10/'; my $tx = $ua->get($url); die qq(Error getting) unless $tx->result->is_success; my $d = $tx->result->dom->find('ul:not([c...
# Fetch latest unicode characters (Linux)
perl -CSAD -Mojo -mcharnames -E 'my $ua = Mojo::UserAgent->new; my $url = "https://blog.emojipedia.org/whats-new-in-unicode-10/"; my $tx = $ua->get($url); die qq(Error getting) unless $tx->result->is_success; my $d = $tx->result->dom->find("ul:not([c...
# Make the client mojo page auto reload/refresh
plugin 'AutoReload';
# Create a simple mojo server and connect to it.
perl -Mojo -E 'say a("/status" => {text => "Active!"})->start("daemon", "-l", "http://*:8088")'
perl -Mojo -E 'a("/hello" => { text => "Welcome!" } )->start' get /hello
#
perl -Mojo -E 'a("/hello" => { text => "Welcome!" } )->start' daemon
perl -Mojo -E 'say a("/hello" => {text => "Hello Mojo!"})->start("daemon")'
perl -Mojo -E 'say a("/hello" => {text => "Hello Mojo!"})->start("daemon", "-l", "http://*:8080")'
mojo get http://127.0.0.1:3000/
#
# View local files on an endpoint:
perl -Mojo -E 'say a("/" => {text => "Hello Mojo!"}); a("ls" => sub{ my @files = glob "*/*"; $_->render( json => \@files) } )->start("daemon")'
mojo get http://127.0.0.1:3000/ls
#
# Show a message on connection.
perl -Mojo -E 'a("/" => sub{ say $_->req->to_string; $_->render( text => "123") })->start' daemon
# View available routes in a mojo server
perl -Mojo -E 'a("/hello" => { text => "Welcome!" } )->start' routes
# Easily create several routes.
perl -Mojo -E 'a "/" => {text => "Main"}; a("/hello" => {text => "Hello"})->start' daemon
# Use text in a CSS selector in Mojo.
perl -Mojo -E 'my $x = x("<A><B>Text1</B></A><A><B>Text2</B></A>"); say $x->at("b:text(Text2)")'
perl -Mojo -E 'my $x = x("<A><B>Text1</B></A><A><B>Text2</B></A>"); say $x->at("a:has(b:text(Text2))")'
perl -Mojo -E 'my $x = x("<A><B>Text1</B></A><A><B>Text2</B></A>"); say $x->at("a:has(b:text(/Text2/))")'
#############################################################
## Perl Modules - Mojo::Base
#############################################################
# Create accessor methods (like Mojo::Base::attr)
sub _has {
no strict 'refs';
for my $attr ( @_ ) {
class_is_path
);
#############################################################
## Perl Modules - Mojo::ByeStream
#############################################################
# Perl Modules - Mojo::ByeStream
# Trying out various encryption algorythms.
perl -Me -e 'say b("abc")->$_ for qw( md5_sum sha1_sum hmac_sha1_sum )'
900150983cd24fb0d6963f7d28e17f72
a9993e364706816aba3e25717850c26c9cd0d89d
cc47e3c0aa0c2984454476d061108c0b110177ae
# Layman's md5 sum:
perl -E 'for(unpack "C32", "an apple a day"){ $s += $_} say $s'
1248
perl -E 'say unpack "%C*", "an apple a day"'
1248
#
# Better ways
perl -Me -e 'say b("an apple a day")->md5_sum'
9f610f0ad8824fb30a086186063e8530
#############################################################
## Perl Modules - Mojo::DOM
#############################################################
# Parsing HTML using regex vs Mojo::DOM
https://mojolicious.io/blog/2018/12/05/compound-selectors/
# Generate html tags using Mojo::DOM. (root,append)
perl -Mojo -E 'my $html = x(); $html->append_content("<a>"); $html->at("a")->attr("target" => "_blank"); say $html'
perl -MMojo::DOM -E 'my $html = Mojo::DOM->new; $html->append_content("<a>"); $html->at("a")->attr("target" => "_blank"); say $html'
# <a target="_blank"></a>
# Generate html tags using Mojo::DOM. (snippet)
perl -MMojo::DOM -E 'my $html = Mojo::DOM->new(qq(<a href="path" >)); $html->at("a")->attr("target" => "_blank"); say $html'
# <a href="path" target="_blank"></a>
# Generate html tags using Mojo::DOM. (conditional)
perl -MMojo::DOM -E 'my $html = Mojo::DOM->new(qq(<a href="path" >)); my $a = $html->at("a"); if(defined $a->attr("href")){ $a->attr("target" => "_blank") } say $html'
# <a href="path" target="_blank"></a>
# Difference between TAG:nth-child(N) and TAG:nth-of-type(N)
# nth-child - positional check first, then TAG check:
#
perl -Mojo -E 'my $dom = x(q(<ul class="clss"> <li>item1</li> <p>para</p> <li>item2</li> </ul>)); say $dom->at("ul > :nth-child(2)")'
# <p>para</p>
#
perl -Mojo -E 'my $dom = x(q(<ul class="clss"> <li>item1</li> <p>para</p> <li>item2</li> </ul>)); say $dom->at("ul > li:nth-child(2)")'
# undef
# Difference between TAG:nth-child(N) and TAG:nth-of-type(N)
# nth-of-type - TAG check first, then positional check.
# if the TAG is not specified, the first TAG found is used.
#
perl -Mojo -E 'my $dom = x(q(<ul class="clss"> <li>item1</li> <p>para</p> <li>item2</li> </ul>)); say $dom->at("ul > li:nth-of-type(2)")'
# <li>item2</li>
#
perl -Mojo -E 'my $dom = x(q(<ul class="clss"> <p>para1</p> <li>item1</li> <p>para2</p> <li>item2</li> </ul>)); say $dom->at("ul > :nth-of-type(2)")'
<p>para2</p>
# Xml to struct in perl
#
+ #!/bin/env perl
+ use feature 'say';
+ use ojo;
+ my $x = x f( shift )->slurp;
+ my $contact = $x->at( "contact" );
+ my $struct = {
+ email => $contact->at( "workplaceemailuri" )->text,
+ first_name => $contact->at( "givenname" )->text,
+ last_name => $contact->at( "familyname" )->text,
+ };
+ say r $struct;
# Get internal strings in html.
perl -MMojo::DOM -E 'my $html_string = "<div><span>Hey </span><span>there!</span></div>"; my $html = Mojo::DOM->new($html_string); say $html->at("div")->all_text'
Hey there!
# Anchor tag/element to the start of the document/root (^)
perl -Mojo -E 'my $x = x f(shift)->slurp; say "[$_]\n\n" for $x->find("feed:root > entry")->each' contacts2.xml
#############################################################
## Perl Modules - Mojo::File
#############################################################
# Pretty print json data to a file
package Mojo::File {
use Mojo::Base qw/ -strict -signatures /;
use Mojo::JSON qw(j);
sub spurt_json ( $self, $struct ) {
my $string = j $struct;
my $_pretty_json = qx(echo '$string' | jq .);
my $pretty_json = encode( "UTF-8", $_pretty_json );
$self->spurt( $pretty_json );
}
}
# Find a path given a class name.
# Alternative to "perldoc -l class".
perl -MMojo::File=path -MMojo::Util=class_to_path -E '$p = class_to_path "Mojo::UserAgent"; for ( @INC ) { $p2 = path($_,$p); if(-e $p2){ say $p2; lat } }'
#############################################################
## Perl Modules - Mojo::IOLoop
#############################################################
# Run Something every few seconds.
perl -Mojo -E 'my $ioloop = a->ua->ioloop; my $n; $ioloop->recurring(2 => sub{ say "hey"; $ioloop->stop if $n++ > 2 } ); $ioloop->start'
#############################################################
## Perl Modules - Mojo::MemoryMap
#############################################################
# Share data/structures between processes.
perl -Mojo -MMojo::MemoryMap -E 'my $map = Mojo::MemoryMap->new; my $w = $map->writer; say r $w->fetch; $w->change(sub{ $_->{abc} = 123 }); say r $w->fetch'
{}
{
"abc" => 123
}
#############################################################
## Perl Modules - Mojo::Parameters
#############################################################
# Access the contents of an array like a hash by key.
perl -MMojo::Util=dumper -E '@a=qw/a 1 b 2 c 3/; %h=@a; say dumper \%h'
#
# This might be more efficient for bigger lists.
perl -MMojo::Parameters -MMojo::Util=dumper -E '@a=qw/a 1 b 2 c 3/; $params = Mojo::Parameters->new(@a); say dumper $params->param("b")'
perl -MMojo::Parameters -MMojo::Util=dumper -E '@a=qw/a 1 b 2 c 3/; $params = Mojo::Parameters->new(@a); say dumper $params->every_param("b")'
#############################################################
## Perl Modules - Mojo::Promise
#############################################################
# Promise usage
perl -Mojo -E "my $p = Mojo::Promise->new; $p->then(sub($robot,$human){ say qq(robot: $robot); say qq(human: $human); }, sub{ say qq!Rejected with: @_!} )->catch( sub{say qq!Error: @_!} ); $p->resolve(qw/Bender Fry Leela/); $p->wait"
# Simple Mojo promise example
perl -MMojo::Promise -E '$p = Mojo::Promise->new; $p->then(sub{say "OK"}); $p->resolve; $p->wait'
perl -MMojo::Promise -E '$p = Mojo::Promise->new; $p->then(sub{say "OK"}, sub{say "BAD"}); $p->resolve; $p->wait'
perl -MMojo::Promise -E '$p = Mojo::Promise->new; $p->then(sub{say "OK"}, sub{say "BAD"}); $p->reject; $p->wait'
# Simple Mojo promise example - timer (OK)/ timeout (BAD)
perl -MMojo::Promise -E "$p = Mojo::Promise->new; $p->then(sub{say 'OK'}, sub{say 'BAD'}); $p->timeout(1); $p->wait"
perl -MMojo::Promise -E "$p = Mojo::Promise->new; $p->then(sub{say 'OK'}, sub{say 'BAD'}); $p->timer(1); $p->wait"
# Chain of promises - short way, but not working for the 2nd level
perl -Mojo -MMojo::Promise -E "my $p = Mojo::Promise->new; $p->then(sub{say '1-OK'}, sub{say '1-BAD'})->then(sub{say '2-OK'}, sub{say '2-BAD'}); $p->reject; $p->wait"
# Chain of promises - long way
perl -Mojo -MMojo::Promise -E "my $p = Mojo::Promise->new; my $p2; $p2 = $p->then(sub{say '1-OK'; $p2->resolve}, sub{say '1-BAD'; $p2->reject}); $p2->then(sub{say '2-OK'}, sub{say '2-BAD'}); $p->reject; $p->wait"
# Using get_p (GET with a promise)
perl -Mojo -MMojo::Promise -E "my $ua = Mojo::UserAgent->new; $ua->get_p(shift)->then(sub{say qq(1-OK: @_)}, sub{say qq(1-BAD: @_)})->wait" mojolicious.org
# Create a list of promises and a top promise to watch them all
perl -MMojo::Promise -E "@p = map { my $p = Mojo::Promise->new; my $n = $_; $p->then(sub{say $n ** 2}, sub{ warn qq(Error in $n\n)}); $p } 1..10; $tp = Mojo::Promise->all(@p)->then(sub{say 'OK'}, sub{say 'NOK'}); $_->resolve for @p; $tp->wait"
#
# Reject a promise
perl -MMojo::Promise -E "@p = map { my $p = Mojo::Promise->new; my $n = $_; $p->then(sub{say $n ** 2}, sub{ warn qq(Error in $n\n)}); $p } 0..10; $tp = Mojo::Promise->all(@p)->then(sub{say 'OK'}, sub{say 'NOK'}); $p[4]->reject; $tp->wait"
#
# Try rejecting/approving
perl -Mojo -MMojo::Promise -E "my @p = map {my $n = $_; my $p = Mojo::Promise->new; $p->then(sub{say qq(P-OK: $n)}, sub{say qq(P-BAD: $n) }); $p } 0..2; my $hop = Mojo::Promise->all(@p)->then(sub{say 'OK'}, sub{say 'BAD'}); $p[$_]->reject for 0,1,2; ...
# Mojo promise race - first one wins
perl -MMojo::Promise -E "@p = map { my $p = Mojo::Promise->new; my $n = $_; $p->then(sub{say $n ** 2}, sub{ warn qq(Error in $n\n)}); $p } 0..10; $race = Mojo::Promise->race(@p)->then(sub{say 'OK'}, sub{say 'NOK'}); $_->resolve for $p[4], @p; $race->...
# HigherOrder Promises
perl -Mojo -MMojo::Promise -E "my @p = map {Mojo::Promise->new} 1..3; my $hop = Mojo::Promise->new; $hop->all(@p)->then(sub{say qq(OK: @_)}, sub{say qq(BAD: @_)}); $hop->wait"
#
# Mojo::Promise::Role::HigherOrder - Not working
perl -MMojo::Promise -E "my @p = map {Mojo::Promise->new} 0..2; my $hop = Mojo::Promise->with_roles('+Any')->any(@p)->then(sub{say 'OK'}, sub{say 'BAD'}); $p[$_]->reject for 0,1,2; $_->resolve for @p; $hop->wait"
perl -MMojo::Promise -E "my @p = map {my $n = $_; my $p = Mojo::Promise->new; $p->then(sub{say qq(\nP-OK$n)}, sub{say qq(\nP-BAD$n) }); $p } 0..2; my $hop = Mojo::Promise->with_roles('+Any')->any(@p)->then(sub{say 'OK'}, sub{say qq(\nBAD)}); $p[$_]->...
# Check if a[href] urls in html files are accessbile
for file in *.xhtml; do echo; echo $file; my_get_ok $(perl -Mojo -E 'my $dom = x f(shift)->slurp; say for $dom->find("a[href]")->map("attr", "href")->each' "$file" | not -r '^\w+\.\w+$' | sort -u); done
my_html_links_check *.xhtml
#############################################################
## Perl Modules - Mojo::UserAgent
#############################################################
# Download a PDF file using Perl
perl -Mojo -E "my $ua = Mojo::UserAgent->new; my $url = Mojo::URL->new('https://hop.perl.plover.com/book/pdf/HigherOrderPerl.pdf'); my $f = $url->path->parts->[-1]; my $tx = $ua->get($url)->result->save_to($f)"
# Download a PDF file using Perl
# Will not download if it is already up to date. (by date)
perl -Mojo -E "my $ua = Mojo::UserAgent->new; my $url = Mojo::URL->new('https://hop.perl.plover.com/book/pdf/HigherOrderPerl.pdf'); my $f = $url->path->parts->[-1]; my $t = (stat($f))[9]; my $d = Mojo::Date->new($t); my $tx = $ua->get($url, {'If-Modi...
# Create a Mojo Websocket and message hooks
perl -Mojo -E "my $ua = Mojo::UserAgent->new; say r $ua->websocket_p('ws://172.17.17.1:80/get_jobs')->then(sub($tx){ my $p = Mojo::Promise->new; $tx->on(finish => sub($tx,$code,$reason){ say qq(Closed with code $code); $p->resolve;}); $tx->on(message...
# Show all the redirects
perl -Mojo -E "my @txs = Mojo::UserAgent->new->max_redirects(10)->head(shift); while(my $tx = $txs[0]->previous){ unshift @txs, $tx } say $_->req->url for @txs" mojolicious.org
perl -Mojo -E "my $tx = Mojo::UserAgent->new->max_redirects(10)->head(shift); say $_->req->url for $tx->redirects->@*, $tx" mojolicious.org
#############################################################
## Perl Modules - Mojo::Util
#############################################################
# steady_time and promises
perl -Mojo -MMojo::Util=steady_time -E "sub st($m){printf qq(%-20s: %s\n), steady_time, $m} st('Before'); my $ua = Mojo::UserAgent->new; for my $url(@ARGV){ st(qq(Trying: $url)); state $cnt = 0; my $label = $cnt++; $ua->get($url => sub{ st(qq(Finishe...
#
cpanm Mojolicious::Plugin::Directory
perl -Mojo -MCwd=getcwd -E 'a->plugin("Directory", root => getcwd())->start' daemon
#############################################################
## Perl Modules - Moose
#############################################################
# Override a method that is defined in a role (Moose)
$Self->meta->add_method(FinishHook => sub { say 'FINISH!!!' });
# Override a class method that is defined in a role (Moose,around)
# Approach 1 - get_method, add_method, execute.
#
+ my $Orig = $Meta->get_method($Method);
+ $Meta->add_method( $Method => sub {
+ my ($Self,%Param) = @_;
+ $Orig->execute($Self,%Param);
+ return 1;
+ });
# Debug a perl script. Find all usage of subroutines and variables
perl -MO=Xref fetch_excel.p | less
#############################################################
## Perl Modules - Object::Pad
#############################################################
# New perl OO example (with an without defaults).
perl -MObject::Pad -E 'class Point { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY } method describe { say "A point at ($x,$y)" } } Point->new->describe'
A point at (0,0)
perl -MObject::Pad -E 'class Point { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY } method describe { say "A point at ($x,$y)" } } Point->new(x=>5, y=>6)->describe'
A point at (5,6)
# New perl OO example (BUILD phase, both)
perl -MObject::Pad -Mojo -E 'class My{ has $x :param; method Say { say "Say(): [@_] self=$self,x=$x"} BUILD { say "BUILD(): [@_]"; qw(x from_build) } sub BUILDARGS { say "BUILDARGS(): [@_]"; qw(x from_buildargs) }} my $s = My->new(x => "new_arg"); $s...
BUILDARGS(): [My x new_arg]
BUILD(): [x from_buildargs]
Say(): [say input] self=My=ARRAY(0xb400006faa2646b8),x=from_buildargs
bless( [
"from_buildargs"
], 'My' )
# New perl OO example (BUILD phase,BUILDARGS)
perl -MObject::Pad -Mojo -E 'class My{ has $x :param; method Say { say "Say(): [@_] self=$self,x=$x"} sub BUILDARGS { say "BUILDARGS(): [@_]"; qw(x from_buildargs) }} my $s = My->new(x => "new_arg"); $s->Say("say input"); say r $s'
BUILDARGS(): [My x new_arg]
Say(): [say input] self=My=ARRAY(0xb4000077e98fd6d8),x=from_buildargs
bless( [
"from_buildargs"
], 'My' )
# New perl OO example (BUILD phase,BUILD)
perl -MObject::Pad -Mojo -E 'class My{ has $x :param; method Say { say "Say(): [@_] self=$self,x=$x"} BUILD { say "BUILD(): [@_]"; qw(x from_build) } } my $s = My->new(x => "new_arg"); $s->Say("say input"); say r $s' BUILD(): ...
Say(): [say input] self=My=ARRAY(0xb4000079688b76d8),x=new_arg
bless( [
"new_arg"
], 'My' )
# New perl OO example (BUILD ADJUST phases)
perl -MObject::Pad -Mojo -E 'class My{ has $x :param; method Say { say "Say(): [@_] self=$self,x=$x"} BUILD { say "BUILD(): [@_]"; qw(x from_build) } sub BUILDARGS { say "BUILDARGS(): [@_]"; qw(x from_buildargs) } ADJUST { say "ADJUST(): [@_] self=$s...
BUILD(): [x from_buildargs]
ADJUST(): [HASH(0xb4000076ffc351f8)] self=My=ARRAY(0xb4000076ffc266d8)
Say(): [say input] self=My=ARRAY(0xb4000076ffc266d8),x=from_buildargs
bless( [
"from_buildargs"
], 'My' )
# New perl OO example (ADJUST strict phases)
perl -MObject::Pad -Mojo -E 'class My :strict(params) { has $x :param; method Say { say "Say(): [@_] self=$self,x=$x"} ADJUST { say "ADJUST(): [@_] self=$self"; qw(x from_adjust) } } my $s = My->new(x => "new_arg", x2 => 2 ); $s->Say("say input"); sa...
ADJUST(): [HASH(0xb400007a337fa2c0)] self=My=ARRAY(0xb400007a337e76b8)
Unrecognised parameters for My constructor: x2 at -e line 1.
#############################################################
## Perl Modules - overload
#############################################################
# Perl Modules - overload example code.
pod Set::Scalar::Base -e
#############################################################
## Perl Modules - PadWalker
#############################################################
# View the lexical variables in a scope.
perl -MPadWalker=peek_my -Mojo -E 'my $var=123; say r peek_my(0)'
{
"\$var" => \123
}
# Call a method of an object obtained from peek_my
perl -MDevel::Peek -MPadWalker=peek_my -Mojo -E '{ package My; sub Func {"My-Func"} } my $var = bless {}, "My"; my $obj_ref = peek_my(0)->{q($var)}; Dump $var; Dump $obj_ref; say $$obj_ref->Func'
# Update a lexical variable in a different scope.
my $lexicals = peek_my(1);
$lexicals->{'@arr'}->[1] = 4;
#############################################################
## Perl Modules - PadWalker::Eval
#############################################################
# Idea for a new module to run eval at a specific scope.
perl -E 'my $v=1; {package My; my $v=2; sub run_code { my ($code) = @_; my $v=3; eval $code }} my $v=4, say My::run_code(q($v))'
# PadWalker::Eval ideas.
sub eval ($string, $scope_level=0)
#############################################################
## Perl Modules - Parallel::ForkManager
#############################################################
# Simple exmplae of parallel processing
# (Perl Modules - Parallel::ForkManager)
# About 3 times slower than using threads!!!
perl -MParallel::ForkManager -E '
my $pm = Parallel::ForkManager->new(30);
for my $file (1..30) {
$pm->start and next;
say "Processing file $file";
sleep(1);
$pm->finish;
}
$pm->wait_all_children;
'
#############################################################
## Perl Modules - PerlIO
#############################################################
# View the encoding layers applied to a filehandle.
perl -E 'say for PerlIO::get_layers(*STDOUT)'
unix
perlio
perl -C -E 'say for PerlIO::get_layers(*STDOUT)'
unix
perlio
utf8
perl -CO -E 'say for PerlIO::get_layers(*STDOUT)'
unix
perlio
utf8
#############################################################
## Perl Modules - Pod::Usage
#############################################################
# Pull out a section from pod
perl -MPod::Usage=pod2usage -E "pod2usage(-input => `perldoc -l ojo`, -verbose => 99, -sections => '.*/x');"
# Pull out a sectin of perl documentation and store it in a variable
perl -MPod::Usage=pod2usage -E "open my $fh, '>', \my $out or die $!; pod2usage(-input => `perldoc -l ojo`, -verbose => 99, -sections => '.*/x', -output => $fh, exitval => 'NOEXIT'); say qq([$out])"
#############################################################
## Perl Modules - POSIX
#############################################################
# Perl Modules - POSIX
# exit vs _exit
# exit calls DESTROY, whereas, _exit does not:
perl -MPOSIX=_exit -E 'sub A::DESTROY { say "DEST" } my $v = bless {}, "A"; exit(0)'
DEST
perl -MPOSIX=_exit -E 'sub A::DESTROY { say "DEST" } my $v = bless {}, "A"; _exit(0)'
#############################################################
## Perl Modules - Role::Tiny
#############################################################
# Light alternative to Mojo::Base -role
package My::Role;
use Role::Tiny;
sub foo { ... }
#############################################################
## Perl Modules - Safe
#############################################################
# Run code in a safer environment
perl -MSafe -le '$comp=Safe->new; $code=q(use v5.10; print "hello Safe!"); $comp->reval($code) or die $@'
'require' trapped by operation mask at (eval 5) line 1.
# Safely run substitution.
# Prevents running other commands (like unlink).
perl -MSafe -E '$_ = "abc"; my $comp = Safe->new; $comp->reval(q(s/./print 123/e)); say $@ if $@; say'
'print' trapped by operation mask at (eval 7) line 1.
abc
perl -MSafe -E '$_ = "abc"; my $comp = Safe->new; $comp->reval(q(s/./print 123/)); say $@ if $@; say'
print 123bc
# Safely run substitution.
# Share/permit a global variable.
perl -MSafe -E 'our $var = "abc"; my $comp = Safe->new; $comp->share(q($var)); $comp->reval(q($var =~ s/./print 123/)); say $@ if $@; say $var'
print 123bc
perl -MSafe -E 'our $var = "abc"; my $comp = Safe->new; $comp->share(q($var)); $comp->reval(q($var =~ s/./print 123/e)); say $@ if $@; say $var'
'print' trapped by operation mask at (eval 7) line 1.
abc
perl -MSafe -E '$_ = "abc"; my $comp = Safe->new; $comp->reval(q(s/.[/print 123/)); say $@=~s/ at .+ line .+//r if $@; say'
Unmatched [ in regex; marked by <-- HERE in m/.[ <-- HERE /
abc
# Permit actions to be done
perl -MSafe -le '$comp=Safe->new; $comp->permit("require"); $code=q(use v5.10; print "hello Safe!"); $comp->reval($code) or die $@'
'print' trapped by operation mask at (eval 5) line 2.
perl -MSafe -le '$comp=Safe->new; $comp->permit(qw(require print)); $code=q(use v5.10; print "hello Safe!"); $comp->reval($code) or die $@'
hello Safe!
# Find/View/see all Opcodes for Safe
cat:
bat:
1.5: 1
1e10: 1
4.5: 1
fat:
# Example of using a dualvar in perl.
use Scalar::Util 'dualvar';
my $name = dualvar 0, 'Fire and Lightning';
say 'Boolenan true' if !! $name;
say 'Numeric true' unless 0 + $name;
say 'String true' if '' . $name;
#############################################################
## Perl Modules - Set::Scalar
#############################################################
# Install library to work with sets
sudo apt-get install libset-scalar-perl
# Working with sets in perl (examples)
perl -MSet::Scalar -le '$s1=Set::Scalar->new(qw/1 2 3/); $s2=Set::Scalar->new(qw/2 4 6/); print for $s1-$s2'
perl -MSet::Scalar -le '$s=Set::Scalar; $s1=$s->new(qw/1 2 3/); $s2=$s->new(qw/2 4 6/); print for $s1-$s2'
# Example of making a set: on init or interatively.
# Set is basically a hash (no doubled keys).
perl -MSet::Scalar -E '
my $s = Set::Scalar->new;
$s->insert($_) for 2,4,6,4;
say $s;
'
(2 4 6)
perl -MSet::Scalar -E '
my $s = Set::Scalar->new(2,4,6,4);
say $s;
'
(2 4 6)
# Get all set elements.
perl -MSet::Scalar -E '
my $s = Set::Scalar->new( 2,4,6,4 );
say for sort $s->elements;
'
2
4
6
#############################################################
## Perl Modules - Socket
#############################################################
print "From Server - $data";
}
close $socket or die $!;
#############################################################
## Perl Modules - Storable
#############################################################
# Create a deep clone of a reference.
perl -MStorable=dclone -E 'my $h={a => [1..2]}; my $h2 = dclone($h); say $_, " ", $_->{a} for $h, $h2'
# Storable error: Max. recursion depth with nested structures exceeded
# Can update the Storable recursion limit with:
$Storable::recursion_limit = 10000;
$Storable::recursion_limit = -1; # Disables all limits.
#
# Create a heavily nested structure.
perl -Me -e '$d = [$d] for 1..1000000; clone $d'
Max. recursion depth with nested structures exceeded at -e line 1.
#
+ my $pkg = caller();
+
+ INIT {
+ no strict 'refs';
+
+ for my $func (sort keys %{"${pkg}::"}) {
+ my $code = ${"${pkg}::"}{$func}->*{CODE};
+ next if not $code;
+
+ ${"${pkg}::"}{$func}->** = sub {
+ say "-> $pkg\::$func";
+ &$code;
+ }
+ }
+ }
+ }
+
+
+ 1
# Subs::Trace use case (example)
perl -I. -E '{ package P; use Subs::Trace; sub F1{10} sub F2{20} } say P::F1() + P::F2()'
# Subs::Trace cpan modules.
cpanm Subs::Trace
perl -E '{ package P; sub F1{10} sub F2{20} sub F4{40} use Subs::Trace; sub F3{30} } say P::F1() + P::F2() + P::F3() + P::F4()'
-> P::F1
-> P::F2
-> P::F4
100
#############################################################
## Perl Modules - Template (Toolkit,tt)
#############################################################
# Concatenation operator in template tookkit (tt)
Data.var1 _ Data.var2
# Compare |html and |uri:
perl -MTemplate -E 'my $out; Template->new->process( \("[% id | html %]"), { id => "has & and spaces" }, \$out); say $out'
has & and spaces
#
perl -MTemplate -E 'my $out; Template->new->process( \("[% id | uri %]"), { id => "has & and spaces" }, \$out); say $out'
has%20%26%20and%20spaces
#############################################################
## Perl Modules - Term::Animation
#############################################################
# Using a terminal animation framework
perl -MTerm::Animation -MCurses -E 'use v5.32; my $anim = Term::Animation->new; halfdelay(2); $anim->new_entity(shape => "<=0=>", position => [3,7,10], callback_args => [1,0,0,0], wrap => 1); while(1){ $anim->animate; my $in = getch(); last if $in eq...
# Using a terminal animation framework (with colors)
perl -MTerm::Animation -MCurses -E 'use v5.32; my $anim = Term::Animation->new; halfdelay(1); $anim->color(1); $anim->new_entity(shape => "<=0=>", position => [3,7,10], callback_args => [1,0,0,0], wrap => 1, default_color => "yellow"); while(1){ $ani...
#############################################################
## Perl Modules - Term::ANSIColor
#############################################################
# Proper way to color text in perl instead of hardcoding
# escape codes (which are not all the same on all devices).
perl -MTerm::ANSIColor -E 'say colored ($_,$_) for qw( RED YELLOW GREEN ON_BRIGHT_BLACK )'
# Color an remote color (uncolor).
perl -MTerm::ANSIColor=colored,colorstrip -E 'say length colorstrip(colored("HEY", "YELLOW"))'
3
#############################################################
## Perl Modules - Term::ProgressBar
#############################################################
# Progress bar example 1
perl -Mojo -MTerm::ProgressBar -CO -E "STDOUT->autoflush(1); my $ua = Mojo::UserAgent->new; $ua->on(prepare => sub($ua,$tx){ my($len,$bar); $tx->res->on(progress => sub($res){ return unless $len ||= $res->headers->content_length; my $prog = $res->con...
GetTerminalSize
# Progress Bar in Perl (more features shown here)
perl -MTerm::ProgressBar -E "$|++; $max=100_000; $progress = Term::ProgressBar->new({count => $max, name => 'File-1', term_width => 50, remove => 1}); $progress->minor(0); my $next_update = 0; for (0..$max){ my $is_power = 0; for (my $i = 0; 2**$i <=...
#############################################################
## Perl Modules - Term::ReadKey
#############################################################
# Get terminal width in perl
perl -MTerm::ReadKey= -E "my ($w) = GetTerminalSize(); say $w"
# Read input from the keyword/user without showing the password
perl -MTerm::ReadKey -le 'ReadMode(2); $pass .= $key while(ord($key = ReadKey(0)) !~ /^(?: 10|13 )$/x); ReadMode(0); print "Got [$pass]"'
# Read input from the keyword/user without showing the password (same, but using keywords)
perl -MTerm::ReadKey -le 'ReadMode(noecho); $pass .= $key while(ord($key = ReadKey(0)) !~ /^(?: 10|13 )$/x); ReadMode(restore); print "Got [$pass]"'
perl -MTerm::ReadKey -e 'ReadMode(2); while($c=ReadKey(0), ord($c) !~ /^(?:10|13)$/x){ $pass .= $c } ReadMode(0); print "[$pass]\n"'
# Read input from the keyword/user without showing the password (same, but more compact)
perl -MTerm::ReadKey -le 'ReadMode(2); $pass = ReadLine(0); chomp $pass; ReadMode(0); print "Got [$pass]"'
#############################################################
## Perl Modules - Tie::Watch
#############################################################
# Tie Watch. OOP interface that hides making packages for tied variables
perl -MTie::Watch -le 'my $v=1; Tie::Watch->new(-variable => \$v, -fetch => sub{my $s=shift; $v=$s->Fetch; $s->Store($v+1); $v}); print $v; print $v; print $v'
# Check when a variable is updated. (watcher)
perl -MTie::Watch -Mojo -le 'my $h={a => [1..2]}; say r $h; Tie::Watch->new( -variable => \$h->{a}, -store => sub{my ($s,$v) = @_; $s->Store($v); my $Scope = 0; while( my ($Pkg,$Line) = caller(++$Scope) ){ say "$Pkg:$Line" } }); sub func{$h->{a}=456}...
# Check when a variable is updated. (watcher)
use Tie::Watch;
Tie::Watch->new(
-variable => \$Self->{Cache}->{ $Param{Type} }->{ $Param{Key} },
-store => sub{
my ($S,$Value) = @_;
$S->Store($Value);
my $Scope = 0;
my $Limit = 5;
while( my ($Package,$Line) = (caller(++$Scope))[0,2] ){
next if $Package =~ /\ATie::/;
say "* Store: $Package line $Line";
last if $Scope >= $Limit;
}
},
);
# Problem using Tie::Watch with Storable::dclone.
perl -MData::Tie::Watch -MStorable -e '$data = {}; $obj = Data::Tie::Watch->new( -variable => $data ); Storable::dclone($data)'
perl -MData::Tie::Watch -MStorable -e '$data = 111; $obj = Data::Tie::Watch->new( -variable => \$data ); Storable::dclone(\$data)'
Can't store CODE items at -e line 1.
# Sample test code.
perl -Me -Ilib -MData::Tie::Watch -e '{ my $data = []; Data::Tie::Watch->new( -variable => $data ); my $d2 = {}; Data::Tie::Watch->new( -variable => $d2 ); } say "DONE"'
perl -Me -Ilib -MData::Trace -e '{ my $d1 = []; my $d2 = {}; Trace($d1); Trace($d2); $d1->[2] = 22; $d2->{cat} = 1 } say "DONE"; use Data::Tie::Watch; p \%Data::Tie::Watch::METHODS'
#############################################################
## Perl Modules - Time::HiRes
#############################################################
# Perl Modules - Time::HiRes
# Higher resolution sleeps.
perl -MTime::HiRes=sleep -E 'sleep 0.25 and say "sleeping" while 1'
#############################################################
## Perl Modules - Time::Moment
#############################################################
# Difference between with_offset_same_instant and with_offset_same_local.
# Instant form will use the time zone from the object (Probably what you want).
perl -MTime::Moment -E '$tm = Time::Moment->now; $tmi = $tm->with_offset_same_instant(0); $tml = $tm->with_offset_same_local(0); say "Normal: $tm"; say "Instance: $tmi"; say "Local: $tml"'
# Normal: 2022-03-10T18:44:46.882016+01:00
# Instance: 2022-03-10T17:44:46.882016Z
# Local: 2022-03-10T18:44:46.882016Z
# Timestamp using milliseconds.
perl -MTime::Moment -E 'say Time::Moment->now->strftime("%Y/%m/%d-%T%3f")'
#############################################################
## Perl Modules - Time::Piece
#############################################################
# Prefer using Time::Piece over DateTime if possible
#
# 1. Less dependencies:
cpanm --showdeps Time::Piece -q | wc -l # 4
perl -MTime::Piece -le "print localtime()->strftime('%Y-%m-%d %H:%M:%S')"
2022-10-04 01:14:00
# Print string or current time in format YYYY-MM-DD
perl -MTime::Piece -le 'print Time::Piece->strptime("20170302 095200 -0400","%Y%m%d %H%M%S %z")->strftime("%Y-%m-%d")'
2017-03-02
perl -MTime::Piece -le 'print localtime->strftime("%Y-%m-%d")'
2022-12-12
# Storage format for transfering/saving timestamp
perl -MTime::Piece -E 'say localtime->strftime("%x %R")'
# Fri 06 Aug 2021 20:06 # Storage format
perl -MTime::Piece -E 'say localtime->strptime("Fri 06 Aug 2021 20:06", "%x %R")'
# Fri Aug 6 20:06:00 2021 # General format
# Set expiration date to start of tomorrow
perl -MTime::Piece -MTime::Seconds -E '$t = localtime; $t += ONE_DAY; say $t->truncate(to => "day")->strftime("%x %R")'
# Sat 07 Aug 2021 00:00
# Set expiration date to start of next week
perl -MTime::Piece -MTime::Seconds -E '$t = localtime; $t += ONE_DAY; $t += ONE_DAY until $t->wdayname eq "Sun"; say $t->truncate(to => "day")->strftime("%x %R")'
# Sun 08 Aug 2021 00:00
# Parse and subtract a second.
perl -MTime::Piece -E '$t = Time::Piece->strptime("2023-02-13T23:00:00Z","%Y-%m-%dT%H:%M:%SZ"); $t -= 1; say $t->strftime("%Y-%m-%d %H:%M")'
2023-02-13 22:59
# Time::Piece strftime sample output:
%a: Mon
%A: Monday
%b: Sep
%B: September
%c: Mon 05 Sep 2016 12:01:18 AM CEST
%C: 20
%d: 05
# Subtract days.
perl -MPOSIX -le '
@t = localtime; $t[3] -= 1299;
print scalar localtime mktime @t
'
# Seconds to HMS (hhmmss)
use Time::Seconds;
my $time = Time::Seconds->new(time - $time0)->pretty;
#
perl -MTime::Seconds -E 'say Time::Seconds->new(time)->pretty;'
# 18845 days, 18 hours, 4 minutes, 21 seconds
#############################################################
## Perl Modules - Tk (General)
#############################################################
# Create a simple Tk window
perl -MTk -le '$mw=MainWindow->new; $mw->title("Hello"); $mw->Button(-text => "Done", -command => sub{exit})->pack; MainLoop'
perl -MTk -MTk::TextStrings -le '$mw=MainWindow->new; $mw->TextStrings(-height => 2, -variable => \$v)->pack; $mw->Entry(-textvariable => \$v)->pack; MainLoop'
#############################################################
## Perl Modules - Try::Tiny
#############################################################
# Simple approach to catching errors
# Try Catch return are subroutine based. Below return unexpectedly (at first) "BBB"
# WARNING: It has issues. Unpredictable syntax
perl -MTry::Tiny -lE 'sub try_me{ try{1/0}catch{say "Caught [$@]"; return "AAA"}; return "BBB" } $v=try_me; say $v'
# A better try/catch approach (only on lnxbr42)
# WARNING: It has issues. Highly dependent upon Perl changes
perl -MTryCatch -lE 'sub try_me{ try{1/0}catch{say "Caught [$@]"; return "AAA"}; return "BBB" } $v=try_me; say $v'
#############################################################
## Perl Modules - Unicode::Normalize
#############################################################
# Compose or decompose unicode strings.
perl -Mcharnames=:full -CO -MUnicode::Normalize -E 'say charnames::viacode ord for split //, NFD "\N{LATIN CAPITAL LETTER A WITH ACUTE}"'
# LATIN CAPITAL LETTER A
# COMBINING ACUTE ACCENT
# Get grapheme clusters.
perl -MEncode -MUnicode::Normalize -E 'use open qw(:std :utf8); say for map{ /(\X)/g } NFD "\x{61}\x{301}"'
aÌ
perl -MEncode -MUnicode::Normalize -E 'use open qw(:std :utf8); say for map{ /(.)/g } NFD "\x{61}\x{301}"'
a
# Get individual decomposed characters.
perl -MEncode -MUnicode::Normalize -E 'use open qw(:std :utf8); say ord for map{ /(.)/g } NFD "\x{61}\x{301}"x2'
97
769
97
769
# LATIN SMALL LETTER A U+61 0x61 97
# COMBINING ACUTE ACCENT U+301 0x301 769
# Use unpack to get unicode codepoints.
perl -MEncode -MUnicode::Normalize -E 'use open qw(:std :utf8); say for unpack "W*",NFD "\x{61}\x{301}"x2'
97
769
97
769
perl -MEncode -MUnicode::Normalize -E 'use open qw(:std :utf8); say for unpack "W*",NFC "\x{61}\x{301}"x2'
225
225
#############################################################
## Perl Modules - utf8
#############################################################
# decode then encode.
perl -MDevel::Peek -E 'my $v = "äöë"; sub c { say "#################"; say "is_utf8: " . utf8::is_utf8($v); say "valid: " . utf8::valid($v); Dump $v } c; utf8::decode($v); c; utf8::encode($v); c'
#################
is_utf8:
valid: 1
SV = PV(0xb400007634f7a0b0) at 0xb400007634f89f98
REFCNT = 2
FLAGS = (POK,IsCOW,pPOK)
PV = 0xb4000074f4f80650 "\xC3\xA4\xC3\xB6\xC3\xAB"\0
CUR = 6
LEN = 10
COW_REFCNT = 1
is_utf8:
valid: 1
SV = PV(0xb400007634f7a0b0) at 0xb400007634f89f98
REFCNT = 2
FLAGS = (POK,pPOK)
PV = 0xb4000074f4f7fd30 "\xC3\xA4\xC3\xB6\xC3\xAB"\0
CUR = 6
LEN = 10
# encode then decode.
perl -MDevel::Peek -E 'my $v = "äöë"; sub c { say "#################"; say "is_utf8: " . utf8::is_utf8($v); say "valid: " . utf8::valid($v); Dump $v } c; utf8::encode($v); c; utf8::decode($v); c'
#################
is_utf8:
valid: 1
SV = PV(0xb400007c1f6780e0) at 0xb400007c1f684f98
REFCNT = 2
FLAGS = (POK,IsCOW,pPOK)
PV = 0xb400007adf667750 "\xC3\xA4\xC3\xB6\xC3\xAB"\0
CUR = 6
LEN = 10
COW_REFCNT = 1
is_utf8: 1
valid: 1
SV = PV(0xb400007c1f6780e0) at 0xb400007c1f684f98
REFCNT = 2
FLAGS = (POK,pPOK,UTF8)
PV = 0xb400007aef66c2e0 "\xC3\x83\xC2\xA4\xC3\x83\xC2\xB6\xC3\x83\xC2\xAB"\0 [UTF8 "\x{c3}\x{a4}\x{c3}\x{b6}\x{c3}\x{ab}"]
CUR = 12
LEN = 24
# upgrade then downgrade.
perl -MDevel::Peek -E 'my $v = "äöë"; sub c { say "#################"; say "is_utf8: " . utf8::is_utf8($v); say "valid: " . utf8::valid($v); Dump $v } c; utf8::upgrade($v); c; utf8::downgrade($v); c'
#################
is_utf8:
valid: 1
SV = PV(0xb4000076231fb0b0) at 0xb400007623207f68
REFCNT = 2
FLAGS = (POK,IsCOW,pPOK)
PV = 0xb4000074e31f46f0 "\xC3\xA4\xC3\xB6\xC3\xAB"\0
CUR = 6
LEN = 10
COW_REFCNT = 1
is_utf8:
valid: 1
SV = PV(0xb4000076231fb0b0) at 0xb400007623207f68
REFCNT = 2
FLAGS = (POK,pPOK)
PV = 0xb4000074f31f6910 "\xC3\xA4\xC3\xB6\xC3\xAB"\0
CUR = 6
LEN = 24
# downgrade then upgrade.
perl -MDevel::Peek -E 'my $v = "äöë"; sub c { say "#################"; say "is_utf8: " . utf8::is_utf8($v); say "valid: " . utf8::valid($v); Dump $v } c; utf8::downgrade($v); c; utf8::upgrade($v); c'
#################
is_utf8:
valid: 1
SV = PV(0xb400007c578710d0) at 0xb400007c5787ef98
REFCNT = 2
FLAGS = (POK,IsCOW,pPOK)
PV = 0xb400007b17878890 "\xC3\xA4\xC3\xB6\xC3\xAB"\0
CUR = 6
LEN = 10
COW_REFCNT = 1
is_utf8: 1
valid: 1
SV = PV(0xb400007c578710d0) at 0xb400007c5787ef98
REFCNT = 2
FLAGS = (POK,pPOK,UTF8)
PV = 0xb400007b278693d0 "\xC3\x83\xC2\xA4\xC3\x83\xC2\xB6\xC3\x83\xC2\xAB"\0 [UTF8 "\x{c3}\x{a4}\x{c3}\x{b6}\x{c3}\x{ab}"]
CUR = 12
LEN = 24
# Playing with utf8
perl -MEncode -C -MDevel::Peek -E '$v = "\x{a7}"; Dump $v; say $v; $v = encode("UTF-8", $v); Dump $v; say $v'
#
# say hex UTF8
# \xa7 # Input
# § \xA7 # Dump
# § \xC2\xA7 # encode("UTF-8",$v)
# § \xC2\xA7 # utf8::encode($v)
# � \xEF\xBF\xBD \x{fffd} # decode("UTF-8",$v)
# § \xA7 # utf8::decode($v)
# § \xC2\xA7 \xA7 # utf8::upgrade($v)
# § \xA7 # utf8::downgrade($v)
# say hex UTF8
# \xC2\XA7 # Input
# § \xC2\xA7 # Dump
# ç \xC3\x82\xC2\xA7 # encode("UTF-8",$v)
# ç \xC3\x82\xC2\xA7 # utf8::encode($v)
# § \xC2\xA7 \xA7 # decode("UTF-8",$v)
# § \xC2\xA7 \xA7 # utf8::decode($v)
# § \xC3\x82\xC2\xA7 \xC2\xA7 # utf8::upgrade($v)
# § \xC2\xA7 # utf8::downgrade($v)
## Perl Modules - XML::Simple
#############################################################
# Read xml file and print out the structure
perl -MXML::Simple -MData::Dumper -le '$xs=XML::Simple->new; print Dumper($xs->XMLin("embraer.xml"))'
# Print the structure of an xml file while reading the input
perl -MXML::Simple -MData::Dumper -le '$d=XML::Simple::XMLin($ARGV[0]//die"\nSyntax: tool xmlfile\n\n"); print Dumper($d)'
# XML::Simple example
perl -Me -MXML::Simple -e 'my $xml = XML::Simple->new; say $xml->XMLout( "hey", AttrIndent => 1, NoAttr => 1, KeyAttr => [], RootName => "RootElement" )'
# Why use XML::Simple AND XML::LibXML together
perl -Me -MXML::Simple -MXML::LibXML -e 'my $x = XML::Simple->new->XMLout( "hey\f", AttrIndent => 1, NoAttr => 1, KeyAttr => [], RootName => "RootElement" ); say(XML::LibXML->load_xml( string => $x))'
:1: parser error : PCDATA invalid Char value 12
<RootElement>hey
</RootElement>
^
perl -Me -MXML::Simple -MXML::LibXML -e 'my $x = XML::Simple->new->XMLout( "hey\f", AttrIndent => 1, NoAttr => 1, KeyAttr => [], RootName => "RootElement" ); say(XML::LibXML->load_xml( string => "abc"))'
#############################################################
## Perl Modules - YAML::XS
#############################################################
# Simple example of converting between yaml and a data structure.
perl -MYAML::XS -E '$yml = Dump [1..3]; $arr = Load $yml'
# 3. Compile
tar -xvzf rakudo.tar.gz
cd rakudo
perl Configure.pl --backend=moar --gen-moar
make
make install
# Rational numbers issues with languages
ruby -e 'puts 0.1 + 0.2 == 0.3'
python -c 'print 0.1 + 0.2 == 0.3'
perl -E 'say 0.1 + 0.2 == 0.3 ? "true" : "false"'
perl6 -e 'say 0.1 + 0.2 == 0.3'
# Find out ip address of current bench
ip addr
# see all methods of an object
perl6 -e 'say "hi there".^methods'
# Generate fibonacci numbers
perl6 -e 'say (1,1,->$a,$b {$a+$b}...*)[^8]'
perl6 -e 'say (1,1,*+*...*)[^8]'
# Fibonacci numbers to at least 40
perl6 -e 'say (1,1, *+* ... * > 40)'
# Even fibonacci numbers up to 4 million
perl6 -e 'say grep * %% 2, (1,1, *+* ... ^ * > 4_000_000)'
# Sum of even fibonacci numbers up to 4 million
perl6 -e 'say [+] grep * %% 2, (1,1, *+* ... ^ * > 4_000_000)'
# Find the summation of numbers
perl6 -e 'say [+] 1..5'
# Find the summation of numbers (with intermediate steps)
perl6 -e 'say [\+] 1..5'
# Find the factorial of numbers
perl6 -e 'say [*] 1..5'
# Find the factorial of numbers (with intermediate steps)
perl6 -e 'say [\*] 1..5'
# Create factorial operator (!)
perl6 -e 'sub postfix:<!> {[*] 1..$^n}; say 5!'
# Create :=: operator (for sorting)
# Use rakudo-star-2017.01 for the interactive shell
perl6 -e 'sub infix:<:=:> ($a is rw, $b is rw) {($a,$b) = ($b,$a)}; my @a=(6,1,5); @a[0] :=: @a[1]; dd @a'
# Return first match (regex)
perl6 -e 'say ~$/ if "abc:def" ~~ /\w+/'
# Return all matches (regex)
perl6 -e 'say ~$/ if "abc:def" ~~ m:g/\w+/'
# Find largest prime factor (of n)
perl6 -e 'my $n=600_475_143; for 2,3,*+2...* {while $n %% $_ {$n div= $_; .say and exit if $_ > $n}}'
# Change named constructor into positional
perl6 -e 'class Point3D{has $.x; has $.y; has $!z; submethod BUILD(:$!x,:$!y,:$!z){say "Init"}; method get{$!x,$!y,$!z} }; my $a = Point3D.new(x=>23,y=>42,z=>2); .say for $a.get'
# Redefine/Create constructor for method new
perl6 -e 'class Point2D{has Numeric $.x; has Numeric $.y; method new($x,$y){$.bless(x=>$x,y=>$y)}; method get{$.x,$.y} }; my $a = Point2D.new(3,4); .say for $a.get'
# Run the debugger on a script
perl6debug sqrt.pl6
# Run the debugger on a one-liner
perl6debug -e '.say for 1..10'
# Debug a regular expression
perl6debug -e '"abc" ~~ /a(.+)c/
# Compare perl6 speeds (rakudo)
cd <RAKUDO_DIR>
perl6=`ls */perl6`
for p in $perl6 perl; do echo; echo "---------------------------------"; echo "$p"; time $p -e 'print join " ", grep /0/, (1..100)'; done
for p in $perl6 perl; do echo; echo "---------------------------------"; echo "$p"; time $p -e 'print 0.1 + 0.2 == 0.3'; done
echo
# Enable selenium service (runs on login)
sudo systemctl enable selenium.service
sudo systemctl start selenium.service
# Run selenium test using curl (for debug)
curl -X POST http://localhost:4444/wd/hub/session -d '{ "desiredCapabilities": { "browserName": "chrome" } }'
curl -X POST http://localhost:4444/wd/hub/session -d '{ "desiredCapabilities": { "browserName": "firefox" } }'
# Type the Enter/Return key in Selenium.
perl -C -E 'say "\N{U+E007}"' 
perl -C -E 'say "\x{E007}"' 
# Make sure to use the apt firefox and not snap
# when seeing: Firefox profile not missing or not accessible.
sudo snap remove firefox
sudo add-apt-repository ppa:mozillateam/ppa
echo '
Package: *
Pin: release o=LP-PPA-mozillateam
Pin-Priority: 1001
' | sudo tee /etc/apt/preferences.d/mozilla-firefox
# 3. Create a filesystem in the mapped container:
sudo mkfs.ext4 /dev/mapper/secret-container
# Ubuntu hard drive encryption.
# SKIP FOR EXTERNAL HARD DRIVES
# 4. Update your /etc/crypttab file (used at system boot):
# Your crypttab should contain a line like
cryptHome UUID=26a4b17a-aad3-436a-89f4-a68a4c4c371d none luks,timeout=30
# with the UUID of the device you just encrypted above
# (i.e. the /dev/sdXX device). You can find it out by using
# e.g. lsblk -f (it should say "crypto_LUKS" under FSTYPE in the output).
# Ubuntu hard drive encryption.
# SKIP FOR EXTERNAL HARD DRIVES
# 5. Update your /etc/fstab file (file system mounting:
# Finally, your fstab should contain a line like
/dev/mapper/cryptHome /home/srto-backup ext4 defaults 0 2
#
# to mount the decrypted partition in your filesystem.
# The mapped name (cryptHome) must match the one you
# defined in the crypttab. Replace username by the name of the actual user.
#############################################################
# Example of using a multiline string in Vim
#
+ " Perl Data Dumper and other useful features all in one mapping.
+ function PerlDev()
+ let l:PERL_DEV = "
+ \\nuse v5.32;
+ \\nuse Mojo::Util qw(dumper);
+ \\nuse Carp qw( croak confess carp cluck );
+ \\nsub WhoAmI { say '--> ' . (caller(1))[3] }
+ \\nsay 'var: ', dumper $var;
+ \\n$Self->HandleException('message'); # New - Test/*
+ \\n$Selenium->HandleError('message'); # Legacy - script/*
+ \\n
+ \\n"
+
+ put =l:PERL_DEV
+ endfunction
+
+ nnoremap <leader>r :call PerlDev()<CR>
# Use local leaders for filetype plugins.
:let maplocalleader = "-"
:nnoremap <localleader>d yyp # Same as:
:nnoremap -d dd
# Create a multiline Vim mapping
nnoremap <leader>r O
\<CR>use v5.32;
\<CR>use Mojo::Util 'dumper';
\<CR>use Carp qw( croak confess carp cluck );
\<CR>say "var: ", dumper $var;
\<CR><ESC>
#############################################################
## Vim Record Macros
#############################################################
# Record a new macro (Vim)
qa # Start recording. Will be put in register "a".
... # Run any commands.
( run in 0.690 second using v1.01-cache-2.11-cpan-d7a12ab2c7f )