App-Cheats
view release on metacpan or search on metacpan
:get_dir
::
SETLOCAL
set key=%1
set val=
::
for /f "tokens=*" %%a in ('perl get_setup.pl %key%') do set val=%%a
if "%val%" == "" (
echo.
echo Error: Cannot determine %key%!
echo.
)
::
(ENDLOCAL & REM
set "%~2=%val%"
)
goto :eof
#############################################################
## Batch - Shell Substitution
#############################################################
# Shell substitution in Windows
@echo off
for /f "tokens=*" %%A in ('perl -x -S -l %0 %*') do set my_path=%%A
echo Going to : %my_path%
cd %my_path%
#############################################################
## Batch - Strings
#############################################################
# Remove double quotes from a variable in dos (windows 10, command prompt)
set a="here is data"
set a=%a:"=%
echo %a%
# Split long commands unto multiple lines (windows 10,caret)
long command^
can be split^
this this
#############################################################
## Batch - Terminal
#############################################################
# 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
https://aquamentus.com/flex_bison.html
# Simple Lexer
%{
#include <iostream>
using namespace std;
extern int yylex();
%}
/*
Compile:
win_flex --outfile=mylex.cpp --wincompat my.l && ^
g++ mylex.cpp -o my.exe
Run:
echo "this is test 123" | my.exe
*/
%option noyywrap
%%
[ \t\n]
[0-9]+\.[0-9]+ { cout << "Float: " << yytext << endl; }
[0-9]+ { cout << "Number: " << yytext << endl; }
[A-Za-z0-9]+ { cout << "String: " << yytext << endl; }
. { cout << "Any: " << yytext << endl; }
%%
int main (int argc, char **argv) {
while( yylex() );
return 0;
}
# Info (flex,bison,parse,regex)
# Flex (and Bison) use a Determinitistic Finite Automata (DFA) regex engine.
# Notes on this engine:
# 1. No look arounds (for the most part). These is LALR and GLR.
# a. LALR - Look Around Left Right with one character of look ahead.
# Faster.
# b. GRL - General Left Right. Slowly but more powerful.
# 2. If multiple patterns can match a string selected pattern (winner) is:
# a. Longest string.
# This means that the order of the pattern does not matter. can do this
# and "CMD" will instead of just "C":
. {...}
CMD {...}
# b. Leftmost if multiple patterns of the same length.
# That is why the last pattern should be a simple dot otherwise it may
# match when not intended. plus very hard to detect this bug.
# 3. Use quotes for literal strings
"CMD"
# 4. Flex patterns return tokens that bison can use.
# - yytext contains the actual value/string found.
# - yylval.sval will be carried over to bison if a value is needed.
# 5. Dollar variable ($1..$n) are the values of the tokens
docker pull mailserver/docker-mailserver:latest
# Check docker processes
docker ps
ctop
#############################################################
## Docker Setup
#############################################################
# Enable cgroups in ubuntu (for docker)
sudo vi /etc/default/grub
GRUB_CMDLINE_LINUX_DEFAULT="quiet splash systemd.unified_cgroup_hierarchy=1 cgroup_enable=memory cgroup_memory=1"
sudo update-grub
reboot
# Check if cgroups is enabled (ubuntu)
cat /proc/cmdline
# Check if using cgroups v1:
ls /sys/fs/cgroup
blkio cpuacct cpuset freezer memory net_cls,net_prio perf_event rdma unified
cpu cpu,cpuacct devices hugetlb net_cls net_prio pids systemd
# Check if using cgroups v2:
ls /sys/fs/cgroup
cgroup.controllers cgroup.max.descendants cgroup.stat cgroup.threads system.slice
cgroup.max.depth cgroup.procs cgroup.subtree_control init.scope user.slice
#############################################################
## Docker Build
#############################################################
# Build a docker image based on the Dockerfile
cd ~/tmp/learning_docker/02-*
docker build .
docker images
# EXPOSE 80 in Dockerfile does nothing
docker run -p 3000:80 <IMAGE_ID>
http://localhost:3000/
docker ps
docker stop <CONTAINER_ID>
# Run interactive container (perl shell)
docker run -it perl
docker run -it py-max
# Restart container for CLI
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 build -t node:12 .
# Assign name to a container
docker run --name my-name IMAGE
# Docker filter images.
-f, --filter value Filter output based on conditions provided (default [])
- dangling=(true|false)
- label=<key> or label=<key>=<value>
- before=(<image-name>[:tag]|<image-id>|<image@digest>)
- since=(<image-name>[:tag]|<image-id>|<image@digest>)
- reference=(pattern of an image reference)
docker image ls -f reference=poti1/my-perl-server
#############################################################
## 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
sudo systemctl start docker.service
#############################################################
## Docker Logs
#############################################################
# View messages from containers.
docker logs CONTAINER
docker logs -f CONTAINER
#############################################################
## Docker Attach/Detach
#############################################################
# Attach to a container.
docker run CONTAINER
docker start -a CONTAINER
# Detach from a container.
docker run -d CONTAINER
#############################################################
## DockerHub (push/pull)
#############################################################
# Need to first create an auth key on dockerhub
docker login -u poti1
# 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 run -v $(pwd)/data:/app/data # Bind mount.
docker run -v $(pwd)/data:/app/data:ro # Bind mount (read-only).
#
# anonymous - closed on shutdown
# named - persistent.
# View docker volumes
# Does NOT show bind mounts.
# Only for development use.
docker volume ls
# Create anonymous docker volume
VOLUME [ "/app/path" ]
# Same as:
-v /app/path
# Create named docker volume
# Not deleted on container shutdown.
# NAME:/PATH_IN_CONTAINER:PERMISSIONS
# NAME should be absolute
docker run -v $(pwd)feedback:/app/feedback feedback-node
docker run -v $(pwd)feedback:/app/feedback:ro feedback-node
# Docker volume gotchas.
# Mount a folder will overwrite all content in container folder.
# If clash of volume paths, longer wins.
docker run -d --rm -p 3000:80 --name feedback-app -v $(pwd)/feedback:/app/feedback -v $(pwd):/app -v /app/node_modules feedback-node
#############################################################
## 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 networking - talk to website.
# Just works "out of the box" by using -p LOCAL_PORT:CONTAINER_PORT
# Docker networking - talk to host machine.
# Need to change url in the address.
# localhost -> host.docker.internal
# Docker networking - talk to another container.
# Every container SHOULD do just one main thing.
# 1 container for the server.
# 1 container for the database.
# Docker networking - steps - 1
docker build -t favorites-node:latest .
docker run --name favorites --rm -p 3000:3000 favorites-node
# Will fail due to:
MongoNetworkError: failed to connect to server [localhost:27017]
# Docker networking - steps - 2
docker pull mongo
docker run -d --name mongodb mongo
docker container inspect mongodb | grep IPAddress
# Can use that IP address.
# Docker networking - Container Networks (WIP).
docker run --network my_network ...
docker run --name favorites --rm -p 3000:3000 --network favorites-net favorites-node
# However networks are NOT automatically created!
# docker: Error response from daemon: network favorites-net not found.
# Docker networking - Container Networks (cleaner solution).
# When in the same network, can use CONTAINER_NAME (mongodb) instead of the HOST in a url.
docker network create favorites-net
docker build -t favorites-node:latest .
docker run -d --rm --network favorites-net --name mongodb mongo
docker run -d --rm --network favorites-net --name favorites -p 3000:3000 favorites-node
#############################################################
## Docker Multi Container Applications
#############################################################
# Docker Multi Container Applications (steps)
docker network create goals-net
docker run -d --rm --network goals-net --name mongodb -v my_mongo_data:/data/db mongo
# Volume can be found on dockerhub or "docker image inspect mongo | grep -A5 Volumes"
cd backend
docker build -t goals-node .
https://minikube.sigs.k8s.io/docs/start/
curl -LO https://storage.googleapis.com/minikube/releases/latest/minikube_latest_amd64.deb
sudo dpkg -i minikube_latest_amd64.deb
# GUI like CLI for minikube
k9s
k9s -n iam-ns
# Docker Kubernetes - Tab completion.
# Minikube tab completion.
if command -v minikube &>/dev/null; then
source <(minikube completion bash)
alias kubectl="minikube kubectl --"
source <(kubectl completion bash)
fi
# Docker Kubernetes - Definitions.
Kubernetes - Nagivator. Framework for deployment.
Still need to handle image/container creation.
Watchdog.
Cluster - Collection of node machines.
Can be given to a cloud provider to setup whats
required for a cluster.
Nodes - Physical or virtual machines.
Master Node - Controls deployments (aka generals)
- API Server - API for kubelet communication.
- Scheduler - Makes new pods if needed (health-check)
- Kube-Controller Manager - Correct pod count.
- Cloud-Controller Manager - Translates to AWS or other providers.
Worker Node - What runs the pod/container (aka soldiers.)
Can run multiple pods.
- Kubelet - communicate between master and worker nodes.
- Docker - run containers.
- Kube-proxy - Control traffic.
Pod - Smallest possible unit (container(s)).
- Containers + resources.
- Atom/indivisible part.
# Docker Kubernetes - Definitions.
Proxy/Config - Setup connection to others/otherside world.
Control Plane - Defines end state.
Services - Logical sets of pods with a unique Pod- and Container-
independent IP address.
# Docker Kubernetes - Definitions.
Kubermatic - Run kubernetes on autopilot.
kubeclt - Send instructions to master node
(which would control work nodes.)
(aka president)
# 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
docker build -t kub-first-app .
minikube delete
minikube status # Check if running already.
minikube start # Check if running already.
minikube profile list # View clusters.
kubectl create deployment first-app --image=kub-first-app
# Fetches image from dockerhub.
kubectl get pod # View container(s).
kubectl get deployments # View pod controllers.
READY
0/1 # One deployment failed since image is not in a cluster.
kubectl delete deployments first-app # Remove a speciic deployment.
# Docker Kubernetes - Simple App Example
docker tag kub-first-app poti1/kub-first-app # Create docker tag
docker image rm kub-first-app # Untag old tag name.
docker push poti1/kub-first-app # Push out new repo.
kubectl describe pod first-app # Debug why an image cant be pulled.
minikube dashboard # Dashboard.
# Read documentation about kubernetes manifest files.
kubectl api-resource
kubectl explain ingresses.spec.rules.http.paths.backend.service.name
# Docker Kubernetes - Service Object.
# Exposes pods to others (since IP addresses change on replacement).
# Groups pods and provides a shared IP.
# Allows external access to pods.
kubectl expose deployment first-app --type=TYPE --port=8080
# Types:
# ClusterIP - (Default) Reachable from within a cluster.
# NodePort - IP address of worker node.
# LoadBalancer - Evenly distribute traffic (Mainly for outside access).
kubectl get service
minikube service first-app # Open a webpage for a service/app.
minikube service first-app --url=true # Only shows the link to the service.
# Docker Kubernetes - Scaling.
# Create 3 pods.
kubectl scale deployment/first-app --replicas=3
kubectl get pod
# Now during a crash (error), another pod can handle traffic.
#
# Scale down.
kubectl scale deployment/first-app --replicas=1
# Docker Kubernetes - Deployment updates.
# Update app.js
# Rebuild image:
# New images are ONLY downloaded (by default) if they have a new tag.
# Set suid for a file
sudo chmod +s file
# Change permission of only the group
chmod g+w file
#############################################################
## Linux Commands - chown
#############################################################
# Fix ownership of user directory
cd home_dir/user_dir
sudo chown -Rh ${PWD##*/} `ls -A`
#############################################################
## Linux Commands - cmatrix
#############################################################
# See the matrix
cmatrix
#############################################################
## Linux Commands - cp
#############################################################
# Update all files that are less than 70 days old according to a file
# (Modified cp command)
cp -s --no-preserve=ownership $FILE `find $DIR/*/$FILE -ctime -70`
# Create a hardlinked folder.
cp -al A B
#############################################################
## Linux Commands - crontab
#############################################################
# Add new crontab
crontab -e
# Start running cron tab
crontab <cron_file>
# View all crontabs on a bench
ls /var/spool/cron/crontabs
# Schedulers
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
#############################################################
# View the heading of a server response
curl --head www.google.com
# Check if website/URL is up (Jira,ping)
curl -s --head http://localhost:8081/secure/Dashboard.jspa | head -1
# Download files using curl and validate the checksum:
curl -LO "https://dl.k8s.io/release/$(curl -L -s https://dl.k8s.io/release/stable.txt)/bin/linux/amd64/kubectl-convert"
curl -LO "https://dl.k8s.io/release/$(curl -L -s https://dl.k8s.io/release/stable.txt)/bin/linux/amd64/kubectl-convert.sha256"
echo "$(cat kubectl-convert.sha256) kubectl-convert" | sha256sum --check
#
# Install the new command.
sudo install -o root -g root -m 0755 kubectl-convert /usr/local/bin/kubectl-convert
#############################################################
## Linux Commands - cut
#############################################################
# Show so many character and everything after on a line
echo "1 2 3 5-d 4" | cut -c5-
#############################################################
## Linux Commands - date
#############################################################
# Format for date timestamps in scripts (primitive)
date "+%Y-%m-%d_%H:%M:%S"
# Convert epoch seconds to absolute time (@ means UNIX timestamp)
perl -le 'print ~~ localtime 1484048121'
date -d @1484048121
date -r 1484048121 # Mac
# Date is taken from a variable/string
tool_log_file=`date --date="@$START_DATE" "+%YY_%mm_%dd_%HH_%MM_%SS"`
#############################################################
## Linux Commands - declare, typeset
#############################################################
# List function declarations/names in bash
declare -F
typeset -F
# List function definitions in bash
echo ${PWD##*/}
# Line number in a bash script
echo $LINENO
#############################################################
## Bash - String Test Operators
#############################################################
# Operator syntax Description
# <INTEGER1> -eq <INTEGER2> True, if the integers are equal.
# <INTEGER1> -ne <INTEGER2> True, if the integers are NOT equal.
# <INTEGER1> -le <INTEGER2> True, if the first integer is less than or equal second one.
# <INTEGER1> -ge <INTEGER2> True, if the first integer is greater than or equal second one.
# <INTEGER1> -lt <INTEGER2> True, if the first integer is less than second one.
# <INTEGER1> -gt <INTEGER2> True, if the first integer is greater than second one.
#############################################################
## Bash - Paths
#############################################################
# Convert a relative path to an absolute path
readlink -f relative_path
# Convert relative to absolute path in perl
use Cwd qw(realpath);
# Compare relative to absolute path reatures (setup readlink)
ll -d file
# Compare relative to absolute path reatures
readlink -f file
readlink -e file
readlink -m file
#############################################################
## Bash - Pipeline
#############################################################
# Redirect STDERR to STDOUT (pipe,bash)
2>&1
|&
# Redirect both STDOUT and STDERR to a pipe
2>&1 | tee out
# Swap STDERR with STDOUT
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
trap signal
# Create an infinite loop (no end)
while true; do echo "$$ $BASHPID"; sleep 1; done
# See all available trap signals
trap -l
# Prevent control-C from doing anything (signal)
abc(){ echo -e "\n\nNOPE"; }
trap abc SIGINT
<Control-C>
# Prompt on a control-C (signal handling)
signal_handler(){ echo -e "\n${RED}Caught Control-C$RESTORE "; read -p "Are you sure you want to abort? (y/n): " ans; [[ $ans =~ [yY] ]] && echo "continue" || echo "exit"; }
trap signal_handler SIGINT
<Control-C>
# Create a timer in bash (aborts the session)
handler(){ echo "done"; exit 1; }
set_timer(){ (sleep $1; kill -ALRM $$)& }
trap handler SIGALRM
set_timer 5
while [ 1 ]; do echo $$; sleep 1; done
# Trap alarm signal
trap 'echo "Hit alarm"; break' SIGALRM
while true; do echo $$; sleep 1; done
# In another window:
kill -s ALRM 11657
# List of Bash signals and meanings.
Signal Standard Action Comment
------------------------------------------------------------------------
SIGABRT P1990 Core Abort signal from abort(3)
SIGALRM P1990 Term Timer signal from alarm(2)
SIGBUS P2001 Core Bus error (bad memory access)
SIGCHLD P1990 Ign Child stopped or terminated
SIGCLD - Ign A synonym for SIGCHLD
SIGCONT P1990 Cont Continue if stopped
SIGEMT - Term Emulator trap
SIGFPE P1990 Core Floating-point exception
SIGHUP P1990 Term Hangup detected on controlling terminal
or death of controlling process
SIGILL P1990 Core Illegal Instruction
SIGINFO - A synonym for SIGPWR
SIGINT P1990 Term Interrupt from keyboard
SIGIO - Term I/O now possible (4.2BSD)
SIGIOT - Core IOT trap. A synonym for SIGABRT
SIGKILL P1990 Term Kill signal
#############################################################
## HTML Element - details
#############################################################
# Create an automatically foldable element in HTML
<details>
<summary>Quick summary</summary>
<h1>All details start here</h1>
<p>and continue till the end</p>
</details>
#############################################################
## HTML Unicode
#############################################################
# HTML Unicode. ZERO WIDTH SPACE.
​ // e2808b
# Zero-width Unicode characters table:
ZERO WIDTH SPACE (U+200B)
Used to indicate word boundaries or add spacing without
affecting the layout visibly.
---
ZERO WIDTH NON-JOINER (U+200C)
Prevents ligatures or joinings between characters, commonly
used in scripts like Arabic and Persian.
---
ZERO WIDTH JOINER (U+200D)
Indicates that two characters should be joined together as
a single glyph.
---
LEFT-TO-RIGHT MARK (U+200E)
Indicates that text following it should be displayed left-
to-right, useful for mixing text with different
directionalities.
---
RIGHT-TO-LEFT MARK (U+200F)
Indicates that text following it should be displayed right-
to-left.
---
LEFT-TO-RIGHT EMBEDDING (U+202A)
Embeds text with a left-to-right directional override.
---
RIGHT-TO-LEFT EMBEDDING (U+202B)
Embeds text with a right-to-left directional override.
---
POP DIRECTIONAL FORMATTING (U+202C)
Resets the directionality to the surrounding context.
---
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">
#############################################################
## Java
#############################################################
# Compile a java program (script)
javac hello.java
# Run a java program (execute script)
java hello
#############################################################
## Javascript - General
#############################################################
# Efficient way in javascript to insert text as html (append to body)
document.querySelector('#id').insertAdjacentHTML('beforeEnd', to_add)
# (works fast, but script tags are not usable).
#
# Use this to allow using script tags
$(id).append(details_rc);
# Stack trace in javascript (js).
try {
// Code throwing an exception
throw new Error();
} catch(e) {
console.log(e.stack);
}
# Javascript log function wrapper.
log (...args) {
const verbose = false;
if (verbose) {
console.log(`[${this.name}]`, ...args);
}
},
#############################################################
## Javascript - Ajax
#############################################################
# Javascript loaded in via ajax is not automatically executed.
# AJAX Javascript Example
function loadDoc() {
var xhttp = new XMLHttpRequest();
xhttp.onreadystatechange = function() {
# When using "make -C" or "make -f" the sub make does NOT
# inherit the parents variables.
# Use "export" to pass down variables to a makefile
export TRUNK_DIR := ../..
# What is MAKEFILE_LIST? (gnu make)
# MAKEFILE_LIST (documented in the manual here) is the list
# of Makefiles currently loaded or included. Each time a
# Makefile is loaded or included the variable is appended.
# The paths and names in the variable are relative to the
# current working directory (where GNU Make was started or
# where it moved to with the -C or --directory option).
# The current working directory is stored in the CURDIR variable.
# Count the number of words in text. (gnu make)
$(words text)
# Extract the nth word (one-origin) of text. (gnu make)
$(word n,text)
# Performs a textual replacement on the text text (gnu make)
# Each occurrence of from is replaced by to.
# The result is substituted for the function call.
$(subst from,to,text)
# Dynamic variable to find out the current makefile path (gnu make)
# and/or makefile directory
whoami = $(word $(words $(MAKEFILE_LIST)), $(MAKEFILE_LIST))
whereami = $(dir $(whoami))
# Debugging code to find out current location (gnu make)
$(info "make pwd is $(CURDIR)")
$(info "shell pwd is $(shell pwd)")
$(info "MAKEFILE_LIST: $(MAKEFILE_LIST)")
$(info "whoami: $(whoami)")
$(info "whereami: $(whereami)")
# Escape dollar sign in a makefile
# Shows available makefile targets (options)
help:
make -pn | perl -lne 'print " $$1" if /^([-a-z]+):/' | sort
# Makefile template (sample,example):
#!/bin/bash
SHELL := /bin/bash
help:
@echo
@echo "Options:"
@make -pn | perl -lne 'print " $$1" if /^([-a-z]+):/' | sort
@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
> ALTER USER 'root'@'localhost' IDENTIFIED WITH mysql_native_password BY 'root';
> CREATE USER 'tim'@'localhost' IDENTIFIED BY 'tim';
> use mysql;
> SELECT User, password_last_changed FROM user;
mysql -u root -proot
cpanm DBD::mysql
# Cannot login to msql with root.
sudo vi /etc/mysql/my.cnf
[mysqld]
skip-grant-tables
# Find duplicates using mysql.
mysql -u otrs -potrs otrs -e '
SELECT col,COUNT(col) from table GROUP BY col HAVING COUNT(col) >
# Run mysql query on the command line.
mysql -u user -ppassword table -e 'query'
# Show a table schema in mysql
DESCRIBE table
# MySQL strange behavior
https://stackoverflow.com/questions/11714534/mysql-database-with-unique-fields-ignored-ending-spaces
# Before comparison using "=", trailing whitespace is removed!!!
# Use LIKE instead.
# INSERT used "=" comparison when checking for duplicates before inserting.
# Fix table that does not seem to be working correctly:
# Data not in DB, but INSERT complains about an existing entry.
# https://dev.mysql.com/doc/refman/8.0/en/optimize-table.html
optimize table my_table;
# Get column count per table (SQL)
SELECT TABLE_NAME, count(*) FROM INFORMATION_SCHEMA.COLUMNS WHERE TABLE_SCHEMA = DATABASE() GROUP BY TABLE_NAME ORDER BY count;
# Make a query take forever to complete
SET SESSION cte_max_recursion_depth = 10000000000000;
WITH RECURSIVE counter(n) AS (SELECT 1 UNION ALL SELECT n % 1 FROM counter WHERE n < 10000000000) SELECT n FROM counter;
# Debug what is slow on MYSQL (Diagnostics,DB)
#
# Currently running or pending connections:
SHOW FULL PROCESSLIST;
KILL QUERY <ID>;
#
# History of commands run:
SELECT * FROM performance_schema.events_statements_summary_by_digest\G
#
# History focused:
Print to pdf
# Simple perl library for generating pdf files
sudo apt-get install libpdf-api2-simple-perl
# Simple perl library for generating pdf files with tables
# Need also PDF::API2
sudo apt-get install libpdf-table-perl
# Get the dimensions of a PNG image file (picture)
sudo apt-get install libimage-size-perl
perl -MImage::Size -le 'print for imgsize("logo.png");'
# HTML to PDF tool
sudo apt-get install wkhtmltopdf
# Send output to pdf
# setup
sudo apt-get install aha
echo -e "Im $RED RED $RESTORE now" | aha
#############################################################
## Perl General
#############################################################
# Zen of Perl
# wget http://www.perlmonks.org/?abspart=1;node_id=752029;displaytype=displaycode;part=1
Beauty is subjective.
Explicit is recommended, but not required.
Simple is good, but complex can be good too.
And although complicated is bad,
Verbose and complicated is worse.
Brief is better than long-winded.
But readability counts.
So use whitespace to enhance readability.
Not because you're required to.
Practicality always beats purity.
In the face of ambiguity, do what I mean.
There's more than one way to do it.
Although that might not be obvious unless you're a Monk.
At your discretion is better than not at all.
Although your discretion should be used judiciously.
Just because the code looks clean doesn't mean it is good.
Just because the code looks messy doesn't mean it is bad.
Reuse via CPAN is one honking great idea -- let's do more of that
# Zen of Perl
According to Larry Wall, there are three great virtues of a programmer; Laziness, Impatience and Hubris
- Laziness:
- 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.
#############################################################
## Perl Arrays
#############################################################
# Function to shuffle/mix the elements of an array
perl -le 'sub shuf{ my @a=\(@_); my $n; my $i=@_; map{ $n=rand($i--); (${$a[$n]}, $a[$n]=$a[$i])[0] }@_ } print for shuf qw/a b c/'
#
# Simplified
perl -le '@a=\(qw/a b c/); $i=@a; print for map{ $n=rand($i--); (${$a[$n]}, $a[$n]=$a[$i])[0] }@a'
perl -le '$i=@a=\(qw/a b c/); print for map{ $n=rand($i--); (${$a[$n]}, $a[$n]=$a[$i])[0] }@a'
#
# Even simplier
# Concept:
# 1. Have references to a list:
# @a = [r1,r2,r3] # where r1=\a, r2=\b, r3=\c
# 2. Spin the dice:
# $n = random from 0 to last element
# 3. return value will be reference value at element $n
# 4. Trick is that each time through the loop:
# A. max element is decreased ($i--)
# B. previous element (which was already used) is assigned the last element size
# a. means that if "a" is selected first time, its spot will be taken by "c".
# in the next round these will be available:
# 0: c # took spot of "a"
# 1: b
# b if "b" is selected first time, "b"'s spot is taken by "c"
# 0: a
# 1: c
# c. if "c" is selected first time, things proceed as normal
# 0: a
# 1: b
perl -le '@a=\(qw/a b c/); $i=@a; map{ $n=rand($i--); print ${$a[$n]}; $a[$n]=$a[$i] }@a'
perl -le '$i=@a=\(qw/a b c/); map{ $n=rand($i--); print ${$a[$n]}; $a[$n]=$a[$i] }@a'
perl -le '$i=@a=\(qw/a b c/); $n=rand($i--), print(${$a[$n]}), $a[$n]=$a[$i] for @a'
perl -le '$i=@a=\(qw/a b c/); print(${$a[$n=rand $i--]}), $a[$n]=$a[$i] for @a'
perl -le '$i=@a=\(qw/a b c/); print ${$a[$n=rand $i--]} and $a[$n]=$a[$i] for @a'
# Get random element of an array in perl.
my @a = 4..10;
print $a [rand ~~@a]
# Print the elements of an array segregated (in parenthesis)
perl -le '@a=qw/this is an array/; local $"=")("; print "(@a)"'
# Split a list into so many parts
# Purpose: Prepare for thread usage.
perl -le '$M=10; $T=3; $from=1; while($to < $M){ $to=$from+(($M-$from+1)/$T--)-1; $to=int($to)+1 if $to != int($to); print "$from -> $to"; $from=$to+1 }'
# Take 3 elements or an array/list at a time
perl -le '@a=0..30; push @b,[splice @a,0,3] while @a; print "@$_" for @b'
# Localized an array slice for a scope
perl -le 'sub pr{print "[@a]"} @a=qw/aa bb cc/; pr; {local @a[0,2]=qw/dd ff/; pr} pr'
# Perl sample array function.
+ sub get_max_length {
+ my $last_row = $#_;
+ my $last_column = $_[0]->$#*;
+
+ my @max = map {
+ 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
28-29-30
31-32-33
34-35-36
37-38-39
40-41-42
43-44-45
46-47-48
49-50-
#############################################################
## Perl Array - Circular
#############################################################
# Perl Array - Circular (idiom)
sub grab_and_rotate ( \@ ) {
my $listref = shift;
my $element = $listref->[0];
push(@$listref, shift @$listref);
return $element;
}
@processes = ( 1, 2, 3, 4, 5 );
while (1) {
$process = grab_and_rotate(@processes);
print "Handling process $process\n";
sleep 1;
}
#############################################################
## Perl Array - Manipulation
#############################################################
# Perl function to transpose a matrix/array/lol.
sub transpose {
my $rows = shift;
my $cols = @{$rows->[0]} || 0;
my @out = map{
my $col = $_;
[map {$_->[$col]} @$rows];
} 0..$cols-1;
\@out;
}
# Perl function in perl.
sub uniq {
my %seen;
grep !$seen{$_}++, @_;
}
},
tr => sub{
local $_ = $copy;
tr///cs;
$_;
}
}, 1000000
'
(warning: too few iterations for a reliable count)
Rate s tr
s 1408451/s -- -70%
tr 4761905/s 238% --
# Comparing different ways in perl to combine hashes.
#
# Each: 2.6s
while ( my ($key,$val) = each %users_one ) {
$users{$key} = $val;
}
#
# Merge: 1.7s
%users = ( %users, %users_one);
#
# Slice: 700ms
@users{keys %users_one} = values %users_one;
# Benchmark glob() vs -e() functions
perl -Me -e '
n {
e_found => sub{ -e "recursive.pl" },
e_not_found => sub{ -e "recursive2.pl" },
glob_found => sub{ glob "recursive.pl" },
glob_not_found => sub{ glob "recursive2.pl" },
glob_wild_flag_found => sub{ glob "rec*.pl" },
glob_wild_flag_not_found => sub{ glob "rec2*.pl" },
}, 1_000_000
'
Rate glob_wild_flag_not_found glob_wild_flag_found glob_found glob_not_found e_found e_not_found
glob_wild_flag_not_found 79491/s -- -45% -94% -95% -96% -98%
glob_wild_flag_found 143885/s 81% -- -90% -91% -93% -96%
glob_found 1408451/s 1672% 879% -- -15% -35% -56%
glob_not_found 1666667/s 1997% 1058% 18% -- -23% -48%
e_found 2173913/s 2635% 1411% 54% 30% -- -33%
e_not_found 3225806/s 3958% 2142% 129% 94% 48% --
#############################################################
## Perl Binary
#############################################################
# 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
9 1001
10 1010
11 1011
12 1100
13 1101
14 1110
15 1111
16 10000
17 10001
18 10010
19 10011
20 10100
21 10101
22 10110
23 10111
24 11000
25 11001
26 11010
27 11011
28 11100
29 11101
30 11110
31 11111
32 100000
33 100001
34 100010
35 100011
36 100100
37 100101
38 100110
39 100111
40 101000
#############################################################
## Perl Bugs
#############################################################
# 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
#############################################################
## Perl Compile
#############################################################
# Compile a perl script into c code (only on lnxbr42) (really slow)
pp -o hello hello.pl
# Run c/cpp code inside perl (Compile)
perldoc Inline
#############################################################
## Perl Configuration
#############################################################
# Print all the perl configuration variables
perl -V:.*
# Check if little or big endian
perl -V:byteorder
byteorder='12345678' # Little
# Show all perl configuration options.
perl -MConfig -Me -e 'p \%Config'
#############################################################
## Perl Debugger
#############################################################
# Library to enable using up arrow key in perl debugger window (-de0)
sudo apt install libreadline-dev
# Check for paste bracketing
bind -V | grep paste
enable-bracketed-paste is set to `on'
#
# Enable paste bracketing
if [ -n "$PS1" ]; then
bind 'set enable-bracketed-paste on'
fi
# Create a perl debug file. Watch parameters. view code around (v) (debugger)
cat > .perldb
@DB::typeahead = (
'{{v',
# 'c',
# 'Nonstop',
# 'frame=0',
#############################################################
## Perl DOS
#############################################################
# Template to use the same file for perl and dos
@REM='
@echo off
perl -x -S -l %0 %*
exit /b
';
#!perl
print "HELLO WORLD";
#############################################################
## Perl Endian
#############################################################
# Check type of endian (little or big)
perl -le 'print unpack "h*", pack "S2",1,2' # 10002000 means little endian
# Big to little endian converter
perl -nle 'print pack "V*", unpack "N*", $_'
# Check if Big Endian
perl -le 'print unpack "H08",pack "L",2'
2 -> 02000000 mean Big Endian
# Force little endian
perl -le 'print unpack "H08",pack "L<",2'
# Force big endian
perl -le 'print unpack "H08",pack "L>",2'
# Convert Big Endian to Little Endian (approach 1)
echo 0x89346512 | perl -ple 's/(\d\d)(\d\d)(\d\d)(\d\d)/$4$3$2$1/'
# Convert Big Endian to Little Endian (approach 2)
echo 0x3487 | perl -ple 's/(?:(\d\d)(\d\d))?(\d\d)(\d\d)/$4$3$2$1/'
echo 0x89346512 | perl -ple 's/(?:(\d\d)(\d\d))?(\d\d)(\d\d)/$4$3$2$1/'
#############################################################
## Perl Error Handling
#############################################################
# Perl Error Handling
# die can return more detailed info. (perl)
eval {
die {
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
#############################################################
## Perl File Test Markers
#############################################################
# Example of reading from the end of file in perl.
while (<DATA>){
$r = /start/../end/;
print if $r > 1 and $r !~ /E0$/;
}
__DATA__
junk1
start
data1
data2
data4
end
junk2
# On systems where $0 cannot be used to find out
# the file size, one can maybe still use <DATA>
# to determine the size of the file.
use POSIX qw(strftime);
$raw_time = (stat(DATA))[9];
$size = -s DATA;
$kilosize = int($size / 1024) . "k";
print "<P>Script size is $kilosize\n";
print strftime(
"<P>Last script update: %c (%Z)\n", localtime($raw_time)
);
__DATA__
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
open(INPUT, "<–") || die; # same thing, but explicit
open(OUTPUT, ">–") || die; # re–open standard output for writing
# Can always use / for files in perl (even on DOS).
my $path = "a\b\c.txt";
my $path = "a/b/c.txt";
# Read piped output in perl.
open PIPE, "-|", "perl out.pl" or die $!;
while( my $line = <PIPE> ){
print $line;
}
close PIPE;
#############################################################
## Perl File Test Operators
#############################################################
# Check if reading from pipe or standard input STDIN keyboard
echo "abc" | perl -le 'print -t STDIN ? "STDIN" : "pipe"' # "pipe"
perl -le 'print -t STDIN ? "STDIN" : "pipe"' # "STDIN"
# Read from either PIPE or from standard input STDIN (in Perl)
perl -le 'push @ARGV, <STDIN> unless -t STDIN; print "[$_]" for @ARGV'
perl -le 'push @ARGV, <STDIN> unless -t; print "[$_]" for @ARGV'
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
#############################################################
# Get Nth column of data (-e must be last)
ll * | perl -ane 'print "$F[8]\n"'
# Auto Split a file using the delimeter 'a' (-e must be last)
perl -F'a' -anle 'print $F[1]' start.txt
# Split according to colon
cat /etc/passwd| perl -F: -ane 'print "@F"'
# Print first argument (with debugging)
echo "abc" | perl -MO=Deparse -le '<> =~ /(b)/; print $1'
# Print first argument if match found
echo "abc" | perl -lne 'print $1 if /(.b.)/'
# Print first argument (with debugging. same but better)
echo "abc" | perl -MO=Deparse -nle '/(b)/; print $1'
# Take out all words from a string and re-sort
echo "abc-def-hij" | perl -lne '@a=/\w+/g; print "@a[2,1,0]"'
# Join all elements found with a different delimeter
echo "abc-def-hij" | perl -lne '@a=/\w+/g; $"=","; print "@a[2,1,0]"'
# Extract columns from PDF like format
cat data3.txt | perl -lpe 's/(?<=\()\s+//' | perl -alne 'print if @F == 3' | perl -lpe 's/\s+/,/g' > data3.csv
# Sort columns by field 5 (who)
who | perl -le 'chomp(@a=<>); print for map{$_->[0]} sort{$a->[1] cmp $b->[1]} map{[$_,(split " ")[5]]} @a'
who |sort -k 5
#############################################################
## Perl Golf - Line Count
#############################################################
# Print the number of lines in a file, left aligned, with 10 character wide (golf)
cat alpha.txt | perl -e '[<>];printf "%010d\n",$.'
# Print the number of lines in a file, left aligned, with 10 character wide (golf)
cat alpha.txt | perl -ne '}{printf"%010d\n",$.'
# Print the number of lines in a file (golf)
cat alpha.txt | perl -ple '}{$_=$.'
# Get line count (golf)
perl -lne '}{ print $.' $1
# Print the number of lines in a file (golf,wc)
cat alpha.txt | perl -pe '}{$_=$.+1e9.$/^v1'
perl -p }{$_=$.+1e9.$/^v1
perl -p }{$_=$.+1e9.$/^chr (1)
#############################################################
## Perl Golf - Read Range
#############################################################
# Extract lines 4 through 10 of a file (golf)
perl -nle 'print if 4..10' sb_devtest.ui
# Print only the first 5 lines of a file (golf,head 5)
cat file | perl -pe '6..exit'
# Print last 5 lines of a file like tail (golf)
cat file | perl -e 'map--$.<5&&print,<>'
# Print last 5 lines of a file like tail (golf,tail 5)
cat file | perl -e 'print+(<>)[-5..-1]'
perl -e 'print+(<>)[-5..-1]'
perl -e '--$.>9||print for <>'
# Read first line of files (golf)
perl -lne 'print "$ARGV :: $_"; close ARGV' aircraft__*
# Read only certain lines in a file (like line 1 or line 5) (golf)
perl -lne 'print "$ARGV :: $_" if $. == 3 ; close ARGV if eof' aircraft__*
# Add line numbers to files.
# ARGV file handle containing currently open file.
perl -pe '
$_ = "$. $_";
close ARGV if eof
' file1 file2
#############################################################
## Perl Golf - tac
#############################################################
# Print a file in reverse order like tac (golf)
cat alpha.txt | perl -e 'print reverse <>'
# 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'
perl -Me -e 'my @q; my %h = ( a => 1 ); push @q, map { ref() ? $_ : \$_ } values %h; $$_ += 3 for @q; p \%h; p \@q'
# Process a hash/array with a queue instead of a recursive approach.
# 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
"""
Note that $_ is an alias to the list value, so it can be used to
modify the elements of the LIST.
"""
# Hash pair slice.
perl -Me -e '%h = ( a => 1, b => 2, c => 3 ); %h2 = %h{qw( a b )}; p \%h; p \%h2'
{
a => 1,
b => 2,
c => 3,
}
{
a => 1,
b => 2,
}
# Hash pair slice with delete.
perl -Me -e '%h = ( a => 1, b => 2, c => 3 ); %h2 = delete %h{qw( a b )}; p \%h; p \%h2'
{
c => 3,
}
{
a => 1,
b => 2,
}
# Perl Hash noop.
# There is one additional caveat that didn’t apply to
# square brackets. Since braces are also used for
# several other things (including blocks), you may
# occasionally have to disambiguate braces at the
# beginning of a statement by putting a + or a
# return in front, so that Perl realizes the opening
# brace isn’t starting a block. For example, if you
# want a function to make a new hash and return a
# reference to it, you have these options:
sub hashem { { @_ } } # Silently WRONG — returns @_.
sub hashem { +{ @_ } } # Ok.
sub hashem { return { @_ } } # Ok.
#############################################################
## Perl Inplace Edit
#############################################################
# Print attempted change of Shebang line
perl -ple 's{^#!.*$}{#!/usr/bin/perl}' my_file
# Change Shebang line of file (without making a backup)
(a*)\2{14}
(a*)\3{15}
$}x;
printf "x=%i y=%i z=%i\n",
map{length}/$r/;
__END__
x=17 y=3 z=2
# Solve an algebra problem. get all solutions to: 3x + 4y + 5z = 100
perl -lE '("a"x100) =~ /^(a*)\1{2}(a*)\2{3}(a*)\3{4}$(?{ printf "3x+4y+5z=100 (x=%s,y=%s,z=%s)\n", map{length}($1,$2,$3) })(*F)/'
# Solve an algebra problem. get all solutions to: 3x + 4y + 5z = 20
perl -lE '("a"x20) =~ /^(a*)\1{2}(a*)\2{3}(a*)\3{4}$(?{ printf "3x+4y+5z=20 (x=%s,y=%s,z=%s)\n", map{length}($1,$2,$3) })(*F)/'
# View all the permutations of a list (List::Permutor)
perl -le '@a=qw(a b c); @rv=(0..$#a); sub n{@ret=@a[@rv]; @h=@rv; @t=pop @h; push @t,pop @h while @h and $h[-1]>$t[-1]; if(@h){ $x=pop @h; ($p)=grep{$x<$t[$_]}0..$#t; ($x,$t[$p])=($t[$p],$x); @rv=(@h,$x,@t) }else{ @rv=() } @ret} print "@n" while @n=n...
# Find the prime numbers
#
# Generate numbers
n=`perl -le 'print for 1..100'`
#
# Simple and incomplete (will report 0 and 1 as prime. they are not prime by definition)
echo "$n" | perl -nle 'sub is_prime{("N" x shift) !~ /^ (NN+?) \1+ $/x} print if is_prime($_)'
#
# Disallow 0 and 1
echo "$n" | perl -nle 'sub is_prime{("N" x shift) !~ /^ N? $ | ^ (NN+?) \1+ $/x} print if is_prime($_)'
echo "$n" | perl -nle 'sub is_prime{("N" x shift) !~ /^(?:N?|(NN+?)\1+)$/} print if is_prime($_)'
#
# "N" to 1
echo "$n" | perl -nle 'sub is_prime{(1 x shift) !~ /^ 1? $ | ^ (11+?) \1+ $/x} print if is_prime($_)'
echo "$n" | perl -nle 'sub is_prime{(1 x shift) !~ /^1?$|^(11+?)\1+$/} print if is_prime($_)'
echo "$n" | perl -nle 'sub is_prime{(1 x shift) !~ /^(?:1?|(11+?)\1+)$/} print if is_prime($_)'
#
# Deparse commands
echo "$n" | perl -MO=Deparse -nle 'sub is_prime{("N" x shift) !~ /^ (NN+?) \1+ $/x} print if is_prime($_)'
#
# Debug Regex 1
echo "$n" | perl -nle 'sub is_prime{($n)=@_; ("N" x $n) !~ /^ (NN+?) (?{ print "Trying: $n. Grouping by: $^N" }) \1+ $/x} is_prime($_); print ""'
#
# Debug Regex 2
echo "$n" | perl -Mre=debug -nle 'sub is_prime{("N" x shift) !~ /^ (NN+?) \1+ $/x} print if is_prime($_)'
# Calculate pi using the formula:
# pi = SUMMATION(x:0.5 to 0.5): 4 / (1 + x^2)
perl -le '$int = 5; $h = 1/$int; for m^C$i(1..$int){ my $x = $h * ($i - 0.5); $sum += 4 / (1 + $x**2) }; $pi = $h * $sum; print $pi'
# Example of having true value that is numerically 0.
# Documented in: perldoc perlfunc
# Can also use "0E0".
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
# of a number is equal to the
# natural log of that number divided
# by the natural log of N. For example:
sub log10 {
my $n = shift;
return log($n)/log(10);
}
# Perl Math
# For other bases, use the mathematical
# identity: log
# log_B(N) = log_e(N) / log_e(B)
# where x is the number whose logarithm you want,
# n is the desired base, and e is the natural
# logarithm base.
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
. . [2.5] 31 3
. . [2.75] 27 1
. . [3] 22 0
. . [3.25] 17 0
. . [3.5] 12 1
. . [3.75] 8 3
. . [4] 4 6
. . [4.25] 2 11
. . [4.5] 0 15
. . [4.75] 0 20
. . [5] 0 25
. . [5.25] 2 30
. . [5.5] 5 34
. . [5.75] 9 37
. . [6] 14 39
. . [6.25] 19 39
. . [6.5] 24 39
#############################################################
## Perl Monitor File Activity
#############################################################
# Create a basic loading hour glass (status bar) (incomplete)
perl -e '$|++; sub p{select undef,undef,undef,0.25} while(`ps -elf | grep watch | grep junk | grep -v $$`){ print "a"; p; print "\b"; p; print "b"; p; print "\b"; p }'
# Create a basic loading hour glass (status bar) Percentage (incomplete)
perl -e '$|++; sub p{select undef,undef,undef,0.5} sub c{print "\b\b\b \b\b\b"} while(`ps -elf | grep watch | grep junk | grep -v $$`){ print "50%"; p; c; print "75%"; p; c; p }'
# Repeat something over and over. use modulus (cycle through)
perl -le '@a=qw/a b c/; print($a[$i++ % @a]),sleep 1 while 1'
# Create a basic loading hour glass (status bar)
perl -e '$|++; sub p{select undef,undef,undef,0.5} sub c{print "\b"} @a=qw( | / - \\ ); while(`ps -elf | grep watch | grep junk | grep -v $$`){ c; print $a[$i++ % @a]; p }'
# Create a basic loading hour glass (status bar) (what to monitor is taken from input)
perl -e '$|++; sub p{select undef,undef,undef,0.5} sub b{print "\b \b"} @a=qw( | / - \\ ); $c=shift; while(eval "`$c`"){ print $a[$i++ % @a]; p; b } print "\n"' 'ps -elf | grep watch | grep junk | grep -v $$'
# Function to print to the same line (loading glass).
sub _SingleLinePrint {
my ( $Self, $LineRaw ) = @_;
my $Line = $Self->_ReplaceColorTags($LineRaw);
my $Length = length($Line);
print "\b" x $Length;
print " " x $Length;
print "\b" x $Length;
print $Line;
return;
}
#############################################################
## Perl Pack
#############################################################
# Check perldoc perlpacktut
# Using pack tutorial
perl -le "print qq([$_]) for unpack 'x3 A2 x4 A3 x4 A2', 'To BE or not to be'"
# Convert a string to its ascii values
perl -le 'print "[$_]" for unpack "C*", "ABC"'
# Convert ascii values to string characters
perl -le 'print "[$_]" for pack "C*", 65,66,67'
perl -le 'print "[$_]" for pack "C*", hex(41),66,67'
# Convert hexidecimal to decimal
perl -le 'print "[$_]" for pack "H*", "41"'
# Pack/convert ordinals to a string of aschii values
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
# 2. Install required modules:
cpanm CPAN::Uploader
cpanm Config::Identity
cpan-upload my_module.tar.gz
#############################################################
## Perl Regular Expressions - General
#############################################################
# Match a number followed by an equal amount of another number
# Dynamic recursive regex
perl -le '$r=qr/0(??{$r})?1/; print "001" =~ $r ? "PASS" : "FAIL"'
#
# Just dynamic
perl -le '$r=qr/0(??{1 x (length $1)})/; print "000111" =~ /^$r$/ ? "PASS" : "FAIL"'
#
# Pattern group (?PARNO)
perl -le '$r=qr/(0(?1)?1)/; print "0011" =~ /^$r$/ ? "PASS" : "FAIL"'
# Perl regex optimization working
echo "line1 Liine2" | perl -nle '$r=qr[(?s-xim:line1(?{print"got line1\n"}).*?line2(?{print"got line2\n"}))]; /$r/'
# 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
# always. There’s a benefit only if the amount of
# time saved is more than the extra time spent
# checking to see whether the optimization is
# applicable in the first place.
#
# In fact, if the engine checks to see if an
# optimization is applicable and the answer is
# “no,†the overall result is slower because it
# includes the fruitless check on top of the
# subsequent normal application of the regex.
#
# So, there’s a balance among how much time an
# optimization takes, how much time it saves,
# 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
Some examples:
/(\d)(\d)/ # Match two digits, capturing them into $1 and $2
/(\d+)/ # Match one or more digits, capturing them all into $1
/(\d)+/ # Match a digit one or more times, capturing the last into $1
# Perl Regular Expressions - Captures
# To avoid this ambiguity, refer to a capture group by its number using \g{NUMBER}, and to an octal character by number using \o{OCTNUM}.
# So \g{11} is always the 11th capture group, and \o{11} is always the character whose codepoint is octal 11
# Perl Regular Expressions - Captures
# branch reset
m{
(?|
(\d+) \s+ (\pL+) # these are $1 and $2
|
(\pL+) \s+ (\d+) # and so is this pair!
)
}x
#############################################################
## Perl Regular Expressions - Character Classes
#############################################################
# Perl recognizes the following POSIX character classes ([[:ascii:]]):
# https://perldoc.perl.org/perlrecharclass#POSIX-Character-Classes
#
alpha Any alphabetical character (e.g., [A-Za-z]).
alnum Any alphanumeric character (e.g., [A-Za-z0-9]).
ascii Any character in the ASCII character set.
blank A GNU extension, equal to a space or a horizontal tab ("\t").
cntrl Any control character. See Note [2] below.
digit Any decimal digit (e.g., [0-9]), equivalent to "\d".
graph Any printable character, excluding a space. See Note [3] below.
lower Any lowercase character (e.g., [a-z]).
print Any printable character, including a space. See Note [4] below.
punct Any graphical character excluding "word" characters. Note [5].
space Any whitespace character. "\s" including the vertical tab ("\cK").
upper Any uppercase character (e.g., [A-Z]).
word A Perl extension (e.g., [A-Za-z0-9_]), equivalent to "\w".
xdigit Any hexadecimal digit (e.g., [0-9a-fA-F]). Note [7].
# Compare perl regular expresion character classe styles.
#
[[:...:]] ASCII-range Full-range backslash Note
Unicode Unicode sequence
-----------------------------------------------------
alpha \p{PosixAlpha} \p{XPosixAlpha}
alnum \p{PosixAlnum} \p{XPosixAlnum}
ascii \p{ASCII}
1234
1234.
1234.1234
1234567
1234567.12345
-1234
-12
$123
$1234
$123456.1234
-$123456.1234
);
my $regex = qr{
(?<!\.) # can't be a period before
(?:\b|\G) # can't float
\d+? # at least one digit before
\K # ignore previous
(?=(?:\d\d\d)+\b)
}x;
for(@nums){
my $before = $_;
s/$regex/,/g;
printf "%-15s -> [%s]\n", $before, $_;
}
__END__
1 -> [1]
1234 -> [1,234]
1234. -> [1,234.]
1234.1234 -> [1,234.1234]
1234567 -> [1,234,567]
1234567.12345 -> [1,234,567.12345]
-1234 -> [-1,234]
-12 -> [-12]
$123 -> [$123]
$1234 -> [$1,234]
$123456.1234 -> [$123,456.1234]
-$123456.1234 -> [-$123,456.1234]
#############################################################
## Perl Regular Expressions - Debugging
#############################################################
# Perl Regular Expressions - Debugging
# Use as: _log("here")
sub _log {
my ( $msg ) = @_;
printf("$msg %s%s%s\n",
dye( $`, "GREEN" ),
dye( $&, "RED" ),
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.
# It’s perhaps mostly academic for flavors that
# support atomic grouping, but can be quite useful
# for those that don’t: if you have positive
# lookahead, and if it supports capturing
# parentheses within the lookahead (most flavors
# do, but Tcl’s lookahead, for example, does not),
# you can mimic atomic grouping and possessive
# quantifiers.
#
# (?>regex) can be mimicked with (?=(regex))\1.
# For example, compare these:
ˆ(?>\w+):
ˆ(?=(\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
#############################################################
## Perl Regular Expressions - Parenthesis
#############################################################
# Perl Regular Expressions - Match Parenthesis
local $_ = 'foo(bar(this), 3.7) + 2 * (that - 1)';
my $r = qr {
(?&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:
# (?(DEFINE)
# (?<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 Regular Expressions - Verbs
#############################################################
# 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
2:
aab
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(@_);
};
}
local %SIG = %SIG;
KEY:
for my $Key ( sort keys %SIG ) {
next KEY if $Key eq 'CHLD';
next KEY if $Key eq 'CLD';
next KEY if $Key eq '__DIE__';
next KEY if $Key eq '__WARN__';
$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
# sending one.
unless (kill 0 => $kid_pid) {
warn "something wicked happened to $kid_pid";
}
#############################################################
## Perl Symbol Table
#############################################################
# Remove a subroutine from the symbol table (perl)
# defined &abs_path will still return 1 since it still exists
# but we removed a reference to it.
delete $Cwd::{'abs_path'}
# Remove the contents of a subroutine (perl)
# defined &abs_path will return 0
# Still found in symbol table
undef $Cwd::{'abs_path'}
# Snippet to capture output in perl.
# Capture output.
my $output = "";
{
local *STDOUT;
local *STDERR;
open STDOUT, ">", \$output or die $!;
open STDERR, ">>", \$output or die $!;
eval { App::Pod->run };
if ( $@ ) {
$output = $@;
chomp $output;
}
}
# Backup and restore STDOUT in perl.
# Backup current STDOUT
open(my $backup_stdout, '>&', STDOUT) or die "Can't duplicate STDOUT: $!";
# Redirect STDOUT to a file
open(STDOUT, '>', 'output.txt') or die "Can't redirect STDOUT: $!";
# Write to the redirected STDOUT
print "This goes to the output.txt file\n";
# Restore original STDOUT
open(STDOUT, '>&', $backup_stdout) or die "Can't restore STDOUT: $!";
# Give a name to an anonymous sub/function.
# Inside the sub.
# Single global variable.
my $code = sub {
local *__ANON__ = 'code_name';
...
};
$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/'
cat my2.out | perl -C -lne '/\d/'
Malformed UTF-8 character: \xe9\x22 (too short; 2 bytes available, need 3) in pattern match (m//) at -e line 1, <> line 1.
Malformed UTF-8 character: \xe9\x22 (unexpected non-continuation byte 0x22, immediately after start byte 0xe9; need 3 bytes, got 1) in pattern match (m//) at -e line 1, <> line 1.
cat my2.out | perl -Mutf8 -C -ne '/\d/'
cat my2.out | perl -C -ne '/\d/'
perl -C -ne '/\d/' < my2.out
perl -CI -ne '/\d/' < my2.out
perl -ne 'INIT{binmode STDIN, ":utf8"} /\d/; print' < my2.out
Malformed UTF-8 character: \xe9\x22\x0a (unexpected non-continuation byte 0x22, immediately after start byte 0xe9; need 3 bytes, got 1) in pattern match (m//) at -e line 1, <> line 1.
perl -ne 'INIT{binmode STDIN, ":encoding(UTF-8)"} /\d/; print' < my2.out
"key": "\xE9"
perl -C -lne 'print utf8::valid($_) ? "valid" : "invalid"' < my.out
valid
perl -C -lne 'print utf8::valid($_) ? "valid" : "invalid"' < my2.out
invalid
#
# Summary:
- A file/string may be declared as utf8, but it really is not.
- "-CI" is the same as 'binmode STDIN, ":utf8"'
- ":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
SV = PV(0xb40000740302e0d0) at 0xb4000074030a93a8
REFCNT = 1
FLAGS = (POK,pPOK,UTF8)
PV = 0xb4000074031623d0 "\xEF\xAC\xA1"\0 [UTF8 "\x{fb21}"]
CUR = 3
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
REFCNT = 1
FLAGS = (POK,IsCOW,pPOK)
PV = 0xb40000721e02c0c0 ""\0
CUR = 0
LEN = 16
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
REFCNT = 1
FLAGS = (POK,IsCOW,pPOK)
PV = 0xb4000071e76df8b0 ""\0
CUR = 0
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
'
#############################################################
## Perl Functions - AUTOLOAD
#############################################################
# Perl Functions - AUTOLOAD
# Undeclared functions are shell commands.
# One can have great fun with AUTOLOAD
# routines that serve as wrappers to other
# interfaces. For example, let’s pretend that
# any function that isn’t defined should just call
# system with its arguments. All you’d do is this:
sub AUTOLOAD {
my $program = our $AUTOLOAD;
$program =~ s/.*:://; # trim package name
system($program, @_);
}
#############################################################
## Perl Functions - Prototypes
#############################################################
# Example of using prototypes in perl.
# Use :proto attribute to mix with signatures.
perl -le '
sub my_map (&@) {
my ($sub,@items) = @_;
for (@items){
$_ = $sub->($_);
}
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.
# For example:
sub myref (\[$@%&*])
# allows calling myref as any of these,
# where Perl will arrange that the function
receives a reference to the indicated argument:
myref $var
myref @array
myref %hash
myref &sub
myref *glob
# Perl function prototype options.
# A semicolon separates mandatory arguments from
# optional arguments.
# Perl function prototype options.
# A * allows the subroutine to accept anything in
# that slot that would be accepted by a built-in as
# a filehandle: a bare name, a constant, a scalar
# expression, a typeglob, or a reference to a
# typeglob.
# Perl function prototype options.
As the last character of a prototype,
or just before a semicolon, you can use _ in
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
#############################################################
# Naturally recursive function using queue technique.
sub run_per_scalar {
my ( $data, $code ) = @_;
my @queue = ( $data );
my %seen;
while ( my $item = shift @queue ) {
next if $seen{$item}++;
my $ref = ref $item;
if ( $ref eq "ARRAY" ) {
unshift @queue, map { ref $_ ? $_ : \$_ } @$item;
}
elsif ( $ref eq "HASH" ) {
unshift @queue, map { ref $_ ? $_ : \$_ } values %$item;
}
elsif ( $ref eq 'SCALAR' ) {
$code->() for $item;
}
elsif( !$ref ){
die "Not a reference!\n";
}
else {
die "Not supported reference type: $ref!\n";
}
}
}
#############################################################
## 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
{
"593943" => [
"From-1"
],
"593944" => [
"From-2"
],
"593945" => [
"From-3"
],
"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"
},
"3" => {
"ChildPid" => 28845,
"Count" => 3,
"Title" => "From-3"
},
"4" => {
"ChildPid" => 28846,
"Count" => 4,
"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
#############################################################
# Numerically sort a list
perl -le "print for sort { $a <=> $b } 1,10,2,5,22"
perl -le "print for sort { $a - $b } 1,10,2,5,22" # Same !?
# 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 (
"bash",
"-c",
"source $ENV{HOME}/my/.bashrc; $command",
);
#############################################################
## Perl Functions - vec
#############################################################
# vec function example
# 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...
#############################################################
## Perl Operators - Range (...)
#############################################################
# 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"
#
# errors
perl -le "use strict; INIT{ $STOP=3 }; print $STOP"
#
# fix1: our
perl -le "use strict; INIT{ our $STOP=3 } our $STOP; print $STOP"
perl -le "use strict; INIT{ our $STOP=3 } print our $STOP"
#
# fix2: "use vars" (BEST way)
perl -le "use strict; use vars qw/$STOP/; 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
perl -le 'print "$_ -> $INC{$_}" for keys %INC'
#############################################################
## Perl Variables - @INC, $ENV{PERL5LIB}
#############################################################
# Can use PERL5LIB to automatically file in @INC.
# Perl Variables - @INC, $ENV{PERL5LIB}
# Old versions of perl can SEGV when it is added
# an interator hook coderef.
#
# While in older versions of perl having a hook
# modify @INC was fraught with issues and could
# even result in segfaults or assert failures,
# as of 5.37.7 the logic has been made much more
# robust and the hook now has control over the
# loop iteration if it wishes to do so.
#############################################################
## Perl Variables - %ENV
#############################################################
# User %ENV and system calls (affect sub process) (Milton)
export ABC=outside
perl -le '$ENV{ABC}="inside"; system q(echo "$ABC")'
# prints inside
# Each sub process has a separate ENV list
perl -le 'system q(export ABC=456; echo "$ABC"); print "-$ENV{ABC}"; system q(echo "$ABC")'
#############################################################
## Perl Variables - %{^HOOK}
#############################################################
# Perl Variables - %{^HOOK}
As of 5.37.10,
prior to any other actions it performs,
require will check if ${^HOOK}{require__before}
contains a coderef, and if it does it will be
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.
#############################################################
## Perl Variables - $/ (IRS)
#############################################################
# Perl Variables - $/ (IRS)
# Commandline -0
-0 - null
-013 - octal new line
-0xd - hex new line
-00 - paragraph mode
-0777 - slurp mode
#
# $/
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
#############################################################
# Find out when a program was started (timestamp)
perldoc -v "$^T"
> $BASETIME
> $^T The time at which the program began running, in seconds since
> the epoch (beginning of 1970). The values returned by the -M,
> -A, and -C filetests are based on this value.
perl -MEnglish -le "print $BASETIME" # 1605178952
perl -le "print $^T"
#############################################################
## Perl Modules - General
#############################################################
# General, interesting trick in perl.
# Given:
My.pm:
package My;
print "In My.pm\n";
My.pmc:
package My;
print "In My.pmc\n";
#
# pmc has precedence:
perl -MMy -e0
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
# explain what a perl program is doing (very concise).
perl -MO=Concise -e 'print 111'
#############################################################
## Perl Modules - B::Deparse
#############################################################
# Perl Modules - B::Deparse
# explain what a perl program is doing (simply)
perl -MO=Deparse -e 'print 111'
#############################################################
## Perl Modules - bignum
#############################################################
# Convert big numbers into full form
# from scientific notation to expanded form
echo "$b" | perl -Mbignum -lpe '$_ += 0'
#############################################################
## 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
# 0x000b x x x x LINE TABULATION
# 0x000c x x x x FORM FEED
# 0x000d x x x x CARRIAGE RETURN
# 0x0020 x x x x SPACE
# 0x0085 x x x x NEXT LINE
# 0x00a0 x x x x NO-BREAK SPACE
# 0x1680 x x x x OGHAM SPACE MARK
# 0x2000 x x x x EN QUAD
# 0x2001 x x x x EM QUAD
# 0x2002 x x x x EN SPACE
# 0x2003 x x x x EM SPACE
# 0x2004 x x x x THREE-PER-EM SPACE
# 0x2005 x x x x FOUR-PER-EM SPACE
# 0x2006 x x x x SIX-PER-EM SPACE
# 0x2007 x x x x FIGURE SPACE
# 0x2008 x x x x PUNCTUATION SPACE
# 0x2009 x x x x THIN SPACE
# 0x200a x x x x HAIR SPACE
# 0x2028 x x x x LINE SEPARATOR
# 0x2029 x x x x PARAGRAPH SEPARATOR
# 0x202f x x x x NARROW NO-BREAK SPACE
# 0x205f x x x x MEDIUM MATHEMATICAL SPACE
# 0x3000 x x x x IDEOGRAPHIC SPACE
# 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
# Create file: cpanfile
requires 'Mojolicious';
recommends 'JSON::XS';
#
# Install perl dependencies from cpanfile:
cpanm --installdeps .
# Install a perl module as root
cpanm -S Selenium::Remote::Driver
cpanm --sudo Selenium::Remote::Driver
#############################################################
## Perl Modules - cpan-outdated
#############################################################
# Update outdated perl modules
cpanm App::cpanoutdated
cpan-outdated | cpanm
#############################################################
## Perl Modules - perltidy
#############################################################
# Clean up perl script
perltidy my_file
# Perltidy configuration file
vi .perltidyrc
-mbl=2 -pt=0 -b -bext='/' -blbs=1 -bom -bbb -nbl
# Tell perltidy to ignore a line
<STDIN>; ## no critic
# html
sudo apt-get install tidy
sudo apt-get install libhtml-tidy-perl # Perl library
# View current options when doing perltidy
perltidy my_file -dop # --dump-options
#############################################################
## Perl Modules - re
#############################################################
# 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"'
# Aliases for threads->create.
perl -lMthreads -le '@t=map threads->new(sub{print $_}), 1..3; $_->join for @t'
perl -lMthreads -le '@t=map async(sub{print $_}), 1..3; $_->join for @t'
perl -lMthreads -le '@t=map threads->new(sub{print $_}), 1..3; $_->join for @t'
# If using a coderef, you must use threads->create.
perl -lMthreads -le '$sub = sub{ print "123" }; @t=map threads->new( $sub ), 1..3; $_->join for @t'
# If using a coderef, you must use threads->create (with arguments).
perl -lMthreads -le '$sub = sub{ print "@_" }; @t=map threads->new( $sub, $_ ), 1..3; $_->join for @t'
# Shared and non shared variables example
perl -lMthreads -Mthreads::shared -le '$a=$b=1; share($a); async(sub{$a++; $b++})->join; print "a=$a, b=$b"'
# Thread pitfall. $a can be either 2 or 3 (race condition)
perl -lMthreads -Mthreads::shared -le '$a=1; share($a); $_->join for map async(sub{my $foo=$a; $a=$foo+1}), 1..2; print "a=$a"'
# Allow only one thread to touch a variable at a time
# This will cause a "deadlock" where one thread requires a reourses
# locked by another thread and vice versa
perl -Mthreads -Mthreads::shared -le 'share $a; share $b; push @t, async(sub{lock $a; sleep 20; lock $b}); push @t, async(sub{lock $b; sleep 20; lock $a}); $_->join for @t'
#
# Alternate syntax 1
perl -Mthreads -le 'my $a :shared; my $b :shared; push @t, async(sub{lock $a; sleep 20; lock $b}); push @t, async(sub{lock $b; sleep 20; lock $a}); $_->join for @t'
#
# Alternate syntax 2
perl -Mthreads -le 'my $a :shared; my $b :shared; push @t, threads->create(sub{lock $a; sleep 20; lock $b}); push @t, threads->create(sub{lock $b; sleep 20; lock $a}); $_->join for @t'
# Thread safe queues. Passing data around
perl -Mthreads -MThread::Queue -le 'my $q=Thread::Queue->new; $t=async(sub{ print "Popped $d off the queue" while $d=$q->dequeue }); $q->enqueue(12); $q->enqueue(qw/A B C/); sleep 1; $q->enqueue(undef); $t->join'
# Thread safe queues. Passing complex data around
perl -Mthreads -MThread::Queue -le 'my $q=Thread::Queue->new; $t=async(sub{ print "Popped @$d off the queue" while $d=$q->dequeue }); $q->enqueue([1..3]); $q->enqueue([qw/A B C/]); sleep 1; $q->enqueue(undef); $t->join'
# Compute pi using parallel threading
time perl -Mthreads -Mthreads::shared -le 'share $sum; $M=100_000_000; $T=6; $h=1/$M; sub sum { my $s; my($from,$to)=@_; for($from..$to){ my $x=$h*($_-0.5); $s += 4/(1+$x**2)}; $s } sub split_by { my($max,$by)=@_; my $from=1; my @l; while($to<$max){ ...
#############################################################
## 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
# Perl install modules found in cpanfile
carton install
# Perl zip modules found in cpanfile
carton bundle
#############################################################
## Perl Modules - CGI
#############################################################
# Make html ordered lists from array lists
perl -MCGI=ol,li -le 'print ol(li([qw/red blue green/]))'
perl -MCGI=ol,li -le 'print ol(li [qw/red blue green/])'
perl -MCGI=ol,li -le 'print ol li [qw/red blue green/]'
# 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: ARRAY(0xb400007e98818a28): [
# 0,
# {
# "complex" => 1
# }
# ]
#
# Tying: HASH(0xb400007e98818698): {
# "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
perl -MData::Dumper -le '$Data::Dumper::Deparse=1; sub add{my($a,$b)=@_; $a+$b}; print Dumper \&add'
perl -MData::Dumper -le '$Data::Dumper::Deparse=1; $add=sub{my($a,$b)=@_; $a+$b}; print Dumper $add'
# Data Dumper subroutine template
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.
perl -MData::Printer -E 'my $var = [1..3, {a => 1, b => 2}, 123]; p $var'
[
[0] 1,
[1] 2,
[2] 3,
[3] {
a 1,
b 2
},
[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.
# Install and export.
cpanm DBI::Profile
export DBI_PROFILE='!Statement'
#
# Report explicitly (instead of on DESTROY)
DBI->trace(1, $DBITraceOutput);
# Simple way to profile MYSQL.
DBI_PROFILE=2 otrs_mysql "select login from users"
# Run the DBI profiler during runtime.
$ENV{DBI_PROFILE} = "!Statement";
require DBI::Profile;
$dbh->{Profile} = DBI::Profile->new();
#############################################################
## Perl Modules - Devel::NYTProf
#############################################################
# Install NYTProf profiler for perl
sudo apt-get install libdevel-nytprof-perl
# Run profiler
perl -d:NYTProf fetch_excel t/data/1-7.xls abc
nytprofhtml
w3m nytprof/index.html
iceweasel nytprof/index.html
# Profile a perl program
cd ~/<USER>/Excel
perl -d:NYTProf fetch_excel Data/1-7.xls 1.7.15
nytprofhtml -o Profiling # View Profiling/index.html in internet explorer
# NYTProf writing to a file.
use Devel::NYTProf qw();
use File::Path qw();
File::Path::make_path($Dir);
#
DB::enable_profile($newfile); # Create or truncate existing file.
DB::enable_profile(); # Append to same file.
#
# Run slow code.
#
DB::finish_profile(); # Stop writing to file.
# NYTProf environment setup.
export PERL5OPT=-d:NYTProf
export NYTPROF='trace=1:start=no'
perl my_script.pl
unset PERL5OPT
unset NYTPROF
# Save nytprof.out to another location.
NYTPROF="file=/tmp/nytprof.out"
# Error when profiling
# Profile data incomplete, inflate error -5 ((null)) at end of input file
#
# Make sure not to run the nytprofhtml command in the same window as:
export NYTPROF='trace=1:start=no'
# Issues: Do NOT "use Devel::NYTProf"!
# It would load the profiler always!
_perl_profiler_setup/_perl_profiler_restore
perl -e 'use Devel::NYTProf'
#
# Instead if needed, use a conditional require.
_perl_profiler_setup/_perl_profiler_restore
perl -e 'require Devel::NYTProf if $ENV{NYTProf}'
#############################################################
## 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;
my $repl = Devel::REPL->new;
$repl->load_plugin($_) for qw(
History
LexEnv
DDS
Colors
Completion
CompletionDriver::INC
CompletionDriver::LexEnv
CompletionDriver::Keywords
CompletionDriver::Methods
);
$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 - Email::Outlook::Message
#############################################################
# Parse an outlook message .msg file
perl -MEmail::Outlook::Message -le 'print Email::Outlook::Message->new(shift)->to_email_mime->as_string' "$m"
#############################################################
## Perl Modules - Enbugger
#############################################################
# Using a read,evaluate,print,loop in perl.
# Not updated since 2014 and failing to build.
#############################################################
## 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"
# Excel - Simple: Check for errors openning an excel file and write to a cell
# Also rename the worksheet
perl -MExcel::Writer::XLSX -E "$wb = Excel::Writer::XLSX->new('my.xlsx') or die qq($!\n); $ws = $wb->add_worksheet('my'); $ws->write('A1', 'Hello Excel'); $wb->close"
# Excel - Simple: Add a format to make a cell bold
perl -MExcel::Writer::XLSX -E "$wb = Excel::Writer::XLSX->new('my.xlsx') or die qq($!\n); $ws = $wb->add_worksheet('my'); $format = $wb->add_format; $format->set_bold; $ws->write(0, 0, 'Hello Excel', $format); $wb->close"
# Create a spreadsheet/excel with formulas using perl (only on lnxbr42)
perl -MExcel::Writer::XLSX -le '
$wb=Excel::Writer::XLSX->new("new.xlsx");
$ws=$wb->add_worksheet;
$ws->write("A1","In Excel");
$ws->write("B2",3);
$ws->write("B3",4);
$ws->write("B4","=B2+B3");
$ws->write("B5","=SUM(B2:B4)");
$wb->close
'
# Create a spreadsheet/excel with color formats using perl (only on lnxbr42)
perl -MExcel::Writer::XLSX -le '
$wb=Excel::Writer::XLSX->new("new2.xlsx");
$ws=$wb->add_worksheet;
$format=$wb->add_format(color => 'red');
$ws->write("A1","No Color");
$ws->write("A2","Red Color", $format);
$wb->close
'
# Create a spreadsheet/excel with color formats using perl (only on lnxbr42). same thing
perl -MExcel::Writer::XLSX -le '
$wb=Excel::Writer::XLSX->new("new2.xlsx");
$ws=$wb->add_worksheet;
$ws->write("A1","No Color");
$ws->write("A2","Red Color", $wb->add_format(color => 'red'));
$wb->close
'
#############################################################
## Perl Modules - File::Copy
#############################################################
# Copy using perl
perl -MFile::Copy -lE 'copy("abc2","abc3")'
#############################################################
## 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
# Bug: does not work with crontab
#
# Better to do this instead:
open STDOUT, "| tee -a $log" or die $!;
open STDERR, "| tee -a $log" or die $!;
#############################################################
## Perl Modules - File::Temp
#############################################################
# Perl Modules - File::Temp
# In recent releases, Perl’s open function offers a
# simple way to create temporary files whose names
# you cannot know.
# Explicitly pass undef as the filename to open:
open(my $fh, "+>", undef)
or die "$0: can't create temporary file: $!\n";
#############################################################
## Perl Modules - Filter::Simple
#############################################################
# Filter::Simple example.
# Change.pm:
package Change;
use Filter::Simple sub{s/abc/ABC/};
1;
#
# Main.pm:
use Change;
print "abcde\n";
#############################################################
## Perl Modules - FindBin
#############################################################
# Perl operator qw does not interpolate variables
# FindBin qw($bin) same as:
# FindBin '$Bin'
perl -le '$a="A"; print for qw/$a $b c/'
#############################################################
## Perl Modules - Getopt::Long
#############################################################
# Extract command line options using a library
perl -MGetopt::Long -MData::Dumper -le 'GetOptions(\%opts, "delim=s"); print Dumper \%opts' 5 3 02 .4f --delim=,
# Get the command line options (perl)
# Option can be used like this:
# -r
# -r VALUE
#
GetOptions(\%opts,
"debug|s",
"quiet|q",
"recursive|r:s", # Takes optional string
);
for($opts{recursive}){
if(defined){ $_ ||= "DEFAULT" } # If blank, use default
else { $_ = 0 } # Do not use option
}
# Pull out flags and data in Perl (command line options, function)
my $is_flag = qr/^ --? (\w[-\w]*) (?:= ([\w,]+) )? $/x;
for(splice @ARGV){
if(/$is_flag/){ $flags{$1} = $2 // 1 }
else { push @data, $_ }
}
#############################################################
## Perl Modules - Hash::Util
#############################################################
# Perl bucket ratio (hash in scalar content)
perl -MHash::Util=bucket_ratio -le "%h=qw(a 1 b 2 c 3 d 4 e 5 f 6); print bucket_ratio %h"
#############################################################
## 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
perl -MHTML::Tree -le '$t=HTML::Tree->new_from_file("rakudo2.html"); $f=$t->find(qw/tr td table/); print $f->as_text'
# Extract latest href download link from an html document
perl -MHTML::Tree -le '$t=HTML::Tree->new_from_file("rakudo.html"); print $_->attr("href") for ($t->look_down(class => "ext-gz"))[0]'
perl -MHTML::Tree -le '$t=HTML::Tree->new_from_file("rakudo.html"); print $t->look_down(class => "ext-gz")->attr("href")'
#############################################################
## Perl Modules - Inline::C
#############################################################
# Example of using Inline::C in perl
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;
if(@ARGV < 2 or $ARGV[0] =~ /^\d$/){
print "\n Syntax: client {add,sub} {numbers}\n\n";
exit 1;
}
my $socket = new IO::Socket::INET(
PeerHost => 'localhost',
PeerPort => 171717,
) or die $!;
print $socket $_ for @ARGV, "END";
my $data = <$socket>; chomp $data;
print "Sum: $data";
$socket->close;
# Simple perl server using IO::Socket::INET.
use IO::Socket::INET;
my %act = (
add => sub{ my($m,$n)=@_; $m+$n },
sub => sub{ my($m,$n)=@_; $m-$n },
);
my $socket = IO::Socket::INET->new(
LocalHost => 'localhost',
LocalPort => '171717',
Listen => 5,
Reuse => 1,
) or die $!;
print "Started Server ...";
while(1){
my $client_socket = $socket->accept;
printf "\nSomeone connected on port=%s, address=%s\n",
$client_socket->peerhost,
$client_socket->peerport;
my $op = <$client_socket>; chomp $op;
my $sum = <$client_socket>; chomp $sum;
print "\nStarting with $sum";
while(<$client_socket>){
chomp;
last if /END/;
next unless /^\d+$/ and $act{$op};
$sum = $act{$op}( $sum, $_ );
printf "%s %s = %s\n", $op, $_, $sum;
}
print "Sum: $sum";
print $client_socket $sum;
}
$socket->close;
#############################################################
## 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)'
#############################################################
## Perl Modules - JavaScript::Minifier::XS
#############################################################
# Minify a javascript file
perl -MJavaScript::Minifier::XS=minify -e "open IN, 'operation-add.js'; open OUT, '>', 'operation-add.min.js'; {local $/; $d=<IN>} print OUT minify($d)"
#############################################################
## Perl Modules - JSON
#############################################################
# Read a json file in perl
perl -MJSON -le "open FH, 'my.json'; local $/; $raw=<FH>; $d = from_json($raw)->{KEY}; print for @$d"
#############################################################
## Perl Modules - Lingua::EN::Tagger
#############################################################
# Add tags to text
perl -MLingua::EN::Tagger -le '$p=Lingua::EN::Tagger->new; print for $p->add_tags("I like food. I like food")'
perl -MLingua::EN::Tagger -le '$p=Lingua::EN::Tagger->new; print for $p->get_readable("I like food. I like food")'
# View natural language lexicon (on lnxbr42)
cd /usr/share/perl5/Lingua/EN/Tagger
perl -MData::Dumper -MStorable -le '$T=retrieve "pos_tags.hash"; print Dumper $T->{pp}'
perl -MData::Dumper -MStorable -le '$W=retrieve "pos_words.hash"; print Dumper $W->{I}'
# Find how likely a certain word is a particular part of speech
cd /usr/share/perl5/Lingua/EN/Tagger
perl -MStorable -le '$W=(retrieve "pos_words.hash")->{I}; $T=(retrieve "pos_tags.hash")->{pp}; print for reverse sort map{ ${$W->{$_}} * $T->{$_} . " $_" } keys $W'
#############################################################
## Perl Modules - List::Util
#############################################################
# Perl Modules - List::Util
# Shuffle the elements of an array.
use List::Util qw(shuffle);
@array = shuffle(@array);
#
# or for a single value
$value = $array[ int(rand(@array)) ];
# Perl Modules - List::Util reduce mimic.
sub My::reduce (&@) {
my $code = shift;
no strict 'refs';
return shift unless @_ > 1;
use vars qw($a $b);
my $c = caller;
local(*{$c."::a"}) = \my $a;
local(*{$c."::b"}) = \my $b;
$a = shift;
foreach (@_) {
$b = $_;
$a = &{$code}();
}
$a;
}
*reduce = *My::reduce;
# print "def2" if defined *reduce{CODE};
print My::reduce {$a + $b} 1..10;
__END__
55
# Perl Modules - List::Util reduce mimic.
sub My::reduce(&@) {
my $sub = shift;
while( @_ > 1 ) {
unshift @_, $sub->(shift, shift);
}
$_[0];
}
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'
#############################################################
## Perl Modules - LWP
#############################################################
# Send a post request (LWP)
u="http://pythonscraping.com/pages/files/processing.php"
perl -MLWP -le '$u=shift; $ua=LWP::UserAgent->new; $ua->env_proxy; $rc=$ua->post($u,{qw/^Crstname FIRST lastname LAST/}); print $rc->content' $u
#############################################################
## Perl Modules - LWP::UserAgent
#############################################################
# 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",
""
], 'Mail::Address' )
bless( [
"",
"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,
"left" => {
"oper" => "const",
"type" => "num",
"val" => 5
},
"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",
"type" => "num",
"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 Other;
use e;
sub Add {
trace();
my ($self,$num) = @_;
return $self->{num} + $num;
}
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
#############################################################
## Perl Modules - Memoize::Storable
#############################################################
# 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.
#############################################################
## Perl Modules - Module::CoreList, corelist
#############################################################
# Find perl module
perl -MModule::CoreList -le 'print for Module::CoreList->find_modules("Class")'
cpan -l | grep -e '^Class'
# Find all available modules for a certain version
perl -MModule::CoreList -le 'print for Module::CoreList->find_modules(/5.010/)'
# Find find release of a perl module
corelist Data::Dumper
# Find all release versions of a perl module
corelist -a Data::Dumper
# Find the release date of a perl version
corelist -r 5.005 # Perl 5.005 was released on 1998-07-22
# Find modules installed with a specific
# perl version.
corelist –v 5.038
#############################################################
## Perl Modules - Module::Refresh
#############################################################
# Perl Modules - Module::Refresh
# My.pm:
#
#!/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;
#
perl -e '
require My;
My->Run();
undef &My::Run;
delete $My::{Run};
require My; Run();
'
111
Undefined subroutine called at -e line 1.
#############################################################
## Perl Modules - Module::Starter
#############################################################
# Create a new distribution in perl abd run it.
x2hs -X Example # Pure Perl
h2xs -A -n Example # XS
perl Makefile.PL
make
perl -Mblib -MExample2 -E 'Example2::print_hello()'
# Using -Mblib is similar to using:
perl -Iblib/lib -Iblib/arch -MExample2 -e 'Example2b::print_hello'
# Create a new distribution in perl.
module-starter --module=My::Test --distro=my-test --author="AUTHOR" --email="EMAIL" --mb --verbose
# Additional folder preparation (module-starter)
mv App-Pod/* .
rmdir App-Pod
mv ignore.txt .gitignore
echo "*.swp" >> .gitignore
chmod +x Build.PL
# Remove MYMETA.* and META.*
#
# Prepend to Build.PL
"#!/bin/env perl
"
# Additional folder preparation (module-starter)
# Add to Build.PL
meta_merge => {
resources => {
bugtracker => 'https://github.com/poti1/data-trace/issues',
repository => 'https://github.com/poti1/data-trace',
},
},
- { os: macos-latest, distribution: strawberry }
- { os: ubuntu-latest, distribution: strawberry }
- { distribution: strawberry, perl-version: "5.8" }
- { distribution: strawberry, perl-version: "5.10" }
- { distribution: strawberry, perl-version: "5.12" }
- { distribution: strawberry, perl-version: "5.34" }
- { distribution: strawberry, perl-version: "5.36" }
runs-on: ${{ matrix.os }}
name: on ${{ matrix.os }} perl ${{ matrix.perl-version }}
steps:
- name: set up perl
uses: shogo82148/actions-setup-perl@v1.28.0
with:
perl-version: ${{ matrix.perl-version }}
distribution: ${{ matrix.distribution }}
- uses: actions/download-artifact@v4
with:
name: build_dir
path: .
- name: install deps using cpanm
uses: perl-actions/install-with-cpanm@v1
with:
cpanfile: "cpanfile"
args: "--with-suggests --with-recommends --with-test"
- run: prove -lr t
env:
AUTHOR_TESTING: 0
RELEASE_TESTING: 0
# Additional folder preparation (module-starter)
# Add meta files.
Build manifest
Build manifest_skip
Build distmeta
Build distcheck
# Build and run a perl distribution (module-starter)
Build.PL
Build # Can use tab completion.
Build test
RELEASE_TESTING=1 Build test
Build disttest
Build dist
#############################################################
## Perl Modules - Mojo
#############################################################
# Mojo DSL
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 ( @_ ) {
*$attr = sub {
return $_[0]{$attr} if @_ == 1; # Get: return $self-<{$attr}
$_[0]{$attr} = $_[1]; # Set: $self->{$attr} = $val
$_[0]; # return $self
};
}
}
_has qw(
path
lol
tree
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);
use Encode qw/ encode /;
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...
#############################################################
## Perl Modules - Mojolicious::Lite
#############################################################
# Mojolicious::Lite simple server example.
+ #!/usr/bin/env perl
+
+ use Mojolicious::Lite -signatures;
+ use Mojo::File qw( path );
+
+ my $file = "story/text.txt";
+
+ get "/" => { text => "REV 1" };
+ get "/page2" => { text => "Page2" };
+ get "/error" => sub { exit 1 };
+
+ get "/story" => sub ($c) {
+ $c->render( json => { story => path($file)->slurp } );
+ };
+ post "/story" => sub ($c) {
+ path($file)->spurt( $c->req->json->{text} );
+ $c->render( text => "Saved!" );
+ };
+
+ app->start("daemon");
#############################################################
## Perl Modules - Mojolicious::Plugin::Directory
#############################################################
# Similar to python's simple http server
python -m SimpleHTTPServer 8080
#
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;
+ });
# Override a class method that is defined in a role (Moose,around)
# Approach 2 - add_method_modifier.
#
+ add_method_modifier $Meta, 'around', [ $Method, sub {
+ my ($Orig,$Self,%Param) = @_;
+ $Self->$Orig(%Param);
+ return 1;
+ }];
# Override a class method that is defined in a role (Moose,around)
# Approach 3 - Moose::around meta.
#
+ # 'around' will not work since it uses currying and
+ # prepends the current class name.
+ # 'Moose::around' avoids currying.
+ Moose::around $Meta, $Method => sub {
+ my ($Orig,$Self,%Param) = @_;
+ $Orig->($Self,%Param);
+ return 1;
+ };
# Override a class method that is defined in a role (Moose,around)
# Approach 4 - Moose::around class.
#
+ Moose::around $Package, $Method => sub {
+ my ($Orig,$Self,%Param) = @_;
+ $Orig->($Self,%Param);
+ return 1;
+ };
# The basic Moose type hierarchy looks like this (perl,OOP):
Any
Item
Bool
Maybe[`a]
Undef
Defined
Value
Str
Num
Int
ClassName
RoleName
Ref
ScalarRef[`a]
ArrayRef[`a]
HashRef[`a]
CodeRef
RegexpRef
GlobRef
FileHandle
Object
#############################################################
## Perl Modules - mro
#############################################################
# As of v5.10, the traversal is configurable.
# In fancy terms, this is the method resolution order, which you select with the mro pragma (see Chapter 29):
# The C3 algorithm traverses @INC so it
# finds inherited methods that are closer
# in the inheritance graph. Said another way, that means that no superclass will be searched before one of its subclasses.
package Mule;
use mro 'c3';
use parent qw(Donkey Horse);
#############################################################
## Perl Modules - Net::SSLeay
#############################################################
# Installation is failing:
cpanm Net::SSLeay
# /usr/bin/ld: cannot find -lz: No such file or directory
# Install:
sudo apt install zlib1g-dev
#############################################################
## Perl Modules - O::Xref
#############################################################
# 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 { ... }
sub bar { ... }
around baz => sub { ... };
#
package My::Class;
use Role::Tiny::With;
# bar gets imported, but not foo
with 'My::Role';
sub foo { ... }
#############################################################
## Perl Modules - Reply
#############################################################
# Using a read,evaluate,print,loop in perl.
# Not working with arrow keys.
perl -MReply -E 'Reply->new->run'
#############################################################
## 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
perl -MOpcode=opdump -e opdump
# Find/View/see all Opcodes for Safe that include a string
perl -MOpcode=opdump -e 'opdump shift' item
# Find Opcode for safe that fints a specific attribute
perl -MOpcode=opdump -e 'opdump shift' ATTRIBUTE
# Run code to evaluate arithemetic
perl -MSafe -le '$comp=Safe->new; $comp->deny(qw(:default)); $comp->permit(qw(padany lineseq const add leaveeval subtract)); while(<>){chomp; $res=$comp->reval($_) or warn $@ and next; print "$_ = $res"}'
#############################################################
## Perl Modules - Scalar::Util
#############################################################
# perl looks_like_number example.
perl -MScalar::Util=looks_like_number -E 'printf("%s: %s\n", $_, looks_like_number($_)) for qw/ 1 cat bat 1.5 1e10 4.5 fat /'
1: 1
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
#############################################################
# Simple client using perl Socket module.
use Socket;
my $socket;
my $port = 171717;
my $address = 'localhost';
my $packed_addr = pack_sockaddr_in(
$port,
inet_aton($address),
);
my $data;
socket $socket, AF_INET, SOCK_STREAM, 0;
connect $socket, $packed_addr or die $!;
while($data = <$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.
#
# Its about depth. This is ok:
perl -MStorable=dclone -e '$Storable::recursion_limit = 2; dclone( [ [ ], [], [], [] ] )'
#
# Whereas, this one is not:
perl -MStorable=dclone -e '$Storable::recursion_limit = 2; dclone( [ [ [] ] ] )'
Max. recursion depth with nested structures exceeded at -e line 1.
# Storable recursion limit seems to be about depth, not size, and not accumulative depth:
perl -MStorable=dclone -e '$Storable::recursion_limit = 3; dclone( [ [ [] ], [ 111, [222] ], [ [ 333, 444] ], [ [ 555, 666 ], [ 777, 888 ], { aaa => 999 }, [], [], [], [], [] ], [], 111 ], )'
# Simple server using perl Socket module.
use Socket;
my ($socket,$new_socket);
my $port = 171717;
my $address = 'localhost';
my $MAX_CONN = 10;
my $packed_addr = pack_sockaddr_in(
$port, inet_aton($address),
);
my $client_addr;
socket $socket, AF_INET, SOCK_STREAM, 0;
bind $socket, $packed_addr or die $!;
setsockopt $socket, SOL_SOCKET, SO_REUSEADDR, 1 or die $!;
listen $socket, $MAX_CONN or die $!;
print "Listening on port=$port, address=$address";
while($client_addr = accept $new_socket, $socket)
{
my $name = gethostbyaddr $client_addr, AF_INET;
print "Someone connected ($name)";
print $new_socket "I'm from the Server";
print $new_socket "I'm from the Server 2";
close $new_socket;
}
#############################################################
## Perl Modules - Subs::Trace
#############################################################
# WhoAmI to all functions in a class.
+ #!/usr/bin/perl
+
+ package Subs::Trace;
+
+ use v5.32;
+
+ sub import {
+ 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...
# Progress Bar example 2
perl -MTerm::ProgressBar -E "$|++; @a=1..100; $bar = Term::ProgressBar->new({count => ~~@a}); $bar->update($_), select undef,undef,undef,0.05 for @a"
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 -MTerm::ReadKey -le 'ReadMode(2); $_ = ReadLine(0); chomp; ReadMode(0); print "[$_]"'
# Read input from the keyword/user without showing the password (same, but on windows)
perl -MTerm::ReadKey -le "ReadMode 2; $pass = ReadLine 0; chomp $pass; ReadMode 0; print qq([$pass])"
# Read input from the keyword/user without showing the password. replace characters with a star "*"
perl -MTerm::ReadKey -e 'ReadMode(4); while($c=ReadKey(0),$o=ord($c),$o != 10 and $o != 13){ if($o == 127 || $o == 8){chop $p; print "\b \b"}elsif($o < 32){}else{ $p .= $c; print "*" }} ReadMode(0); print "[$p]\n"'
perl -MTerm::ReadKey -e 'ReadMode 3; while($c=ReadKey(0),$o=ord($c),$o != 10 and $o != 13){ if($o == 127 || $o == 8){chop $p; print "\b \b"}elsif($o < 32){}else{ $p .= $c; print "*" }} ReadMode 0; print "[$p]\n"'
perl -MTerm::ReadKey -e 'ReadMode 4; while($c=ReadKey(0),$o=ord($c),$o!=10){ if($o==127 or $o==8){chop $p; print "\b \b"}elsif($o < 32){}else{$p.=$c; print "*"}} ReadMode 0; print "[$p]\n"'
#############################################################
## Perl Modules - Term::ReadLine::Gnu
#############################################################
# Given input, return the possible completion words.
# Like compgen.
compgen -W "cat cake bat bake" -- c
perl -MTerm::ReadLine -E 'my $term = Term::ReadLine->new("my"); my $attribs = $term->Attribs; $attribs->{completion_word} = [qw( cat cake bat bake )]; my @matches = $term->completion_matches( shift//"", $attribs->{list_completion_function} ); $term->...
#############################################################
## Perl Modules - Text::CSV
#############################################################
# Write a csv file (super easy)
perl -MText::CSV_XS=csv -E "csv(in => [[qw/A B C/],[1,2,3]], out => 'my.csv')"
# Read certain lines of a CSV file
perl -l -MText::CSV -e '$csv=Text::CSV->new; open FH, "book1.csv"; while($a=$csv->getline(FH)){print $a->[0]}'
# CSV file into an array (Mike)
perl -l -MText::CSV_XS -e '$csv=Text::CSV_XS->new; open FH, "a.csv"; $a=$csv->getline_all(FH); print $a->[1][3]'
#############################################################
## Perl Modules - Text::ParseWords
#############################################################
# Split a line by a character while honoring quotes
# and backslashes. (perl)
use Text::ParseWords qw/ parse_line /;
parse_line( '/', 1, $string );
# Perl Modules - Text::ParseWords example.
use Text::ParseWords;
my @a = map{
chomp;
[shellwords($_)]
} <DATA>;
# Perl Modules - Text::ParseWords example.
sub get_file_data{
use Text::ParseWords;
map{chomp; [quotewords('\s+', 1, $_)]} <DATA>;
}
#############################################################
## Perl Modules - Tie::Array
#############################################################
# Tie a simple array variable
perl -MData::Dumper -MTie::Array -le 'tie @a, "Tie::StdArray"; @a=(1,3,4); print Dumper tied @a'
#############################################################
## Perl Modules - Tie::File
#############################################################
# Tie an array to a file
perl -MTie::File -le 'tie @file,"Tie::File","array.pl"; print $file[4]'
#############################################################
## Perl Modules - Tie::Hash
#############################################################
# Tie a simple hash variable
perl -MData::Dumper -MTie::Hash -le 'tie %h, "Tie::StdHash"; $h{age}=123; print Dumper tied %h'
# Tie append hash example.
package Tie::AppendHash;
use Tie::Hash;
our @ISA = qw(Tie::StdHash);
sub STORE {
my ($self, $key, $value) = @_;
push @{$self->{$key}}, $value;
}
#############################################################
## Perl Modules - Tie::Scalar
#############################################################
# Tie a simple scalar variable
perl -MData::Dumper -MTie::Scalar -le 'tie $n, "Tie::StdScalar"; $n=5; print Dumper tied $n'
perl -Me -MTie::Scalar -e 'my $obj = tie $var, "Tie::StdScalar"; $var=5; p $var; p $obj'
# Tie to scalar (without template)
perl -le '{package P; sub TIESCALAR{my($c,$o)=@_; bless \$o,$c} sub FETCH{my($s)=@_; $$s} sub STORE{my($s,$v)=@_; $$s = $v} } tie $var, "P", 123; print $var; $var=42; print $var'
#############################################################
## 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
cpanm --showdeps DateTime -q | wc -l # 35
#
# 2. Issues with using DateTime and cron.
# Could be due to also perlbrew trying a different
# library path (which I could not resolve).
# Print the currect time, the inputed time, and difference in seconds (accounts for timezone offset)
perl -MTime::Piece -le '$now=localtime; $t=Time::Piece->strptime("20170320 095200 -0400","%Y%m%d %H%M%S %z"); print $_->strftime," ",$_->tzoffset for $now,$t; print $now-$t'
# Compare the current time to a string (desired). Accounts for time zone
perl -MTime::Piece -le '$now=localtime; $now+=$now->tzoffset; print $now; $t=Time::Piece->strptime("Mon Apr 17 14:36:02 2017","%a %b %d %H:%M:%S %Y"); print $now-$t'
# Compare the current time to a string (desired). Accounts for time zone (compact)
perl -MTime::Piece -le '$now=localtime; $now+=$now->tzoffset; print $now; $t=Time::Piece->strptime("Mon Apr 17 14:36:02 2017","%c"); print $now-$t'
# Compare the curent time to a string. Show direrence in seconds between times
perl -MTime::Piece -le '$now=localtime; $now+=$now->tzoffset; $t=Time::Piece->strptime(shift,"%c"); print for $now,$t,$now-$t' "Mon Apr 17 14:36:02 2017"
# Print current time in format YYYYMMDD
perl -MTime::Piece -le "print localtime()->strftime('%Y%m%d')"
# Print current time in format YYYY-MM-DD HH::MM:SS
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
%D: 09/05/16
%e: 5
%E: %E
%F: 2016-09-05
%G: 2016
%g: 16
%h: Sep
%H: 00
%I: 12
%j: 249
%k: 0
%l: 12
%m: 09
%M: 01
%n: \n
%O: %O
%p: AM
%P: am
%r: 12:01:18 AM
%R: 00:01
%s: 1473026478
%S: 18
%t: \t
%T: 00:01:18
%u: 1
%U: 36
%V: 36
%w: 1
%W: 36
%x: 09/05/2016
%X: 12:01:18 AM
%y: 16
%Y: 2016
%z: +0200
%Z: CEST
%+: %+
%%: %
#############################################################
## Perl Modules - Time::Seconds
#############################################################
# Date arithmetic in Javascript (add 90 days to a date)
# Time::Seconds imports ONE_DAY
perl -MTime::Seconds -MTime::Piece -le "$now=localtime; $now+=$now->tzoffset; $now += ONE_DAY * 90; print $now->strftime('%Y-%m-%d')"
# 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'
# Create a simple grid window
perl -MTk -le '$m=MainWindow->new; $m->Button->grid($m->Button,$m->Button); $m->Button->grid($m->Button,$m->Button); MainLoop'
# Create a simple grid window with last button spanning several columns
perl -MTk -le '$m=MainWindow->new; $m->Button->grid($m->Button,$m->Button); $m->Button->grid($m->Button,"-", -sticky => "nsew"); MainLoop'
# Create a simple grid window with last button spanning several rows
perl -MTk -le '$m=MainWindow->new; $m->Button->grid($m->Button,$m->Button, -sticky => "nsew"); $m->Button->grid($m->Button,"^"); MainLoop'
# Create a simple grid window with last button removed/ignored/skipped
perl -MTk -le '$m=MainWindow->new; $m->Button->grid($m->Button,$m->Button); $m->Button->grid("x",$m->Button, -sticky => "nsew"); MainLoop'
# Have a button to disable another button
perl -MData::Dumper -MTk -wle '
$mw = MainWindow->new;
$exit_b = $mw->Button(-text => "exit", -command => sub{exit})->pack(-ipadx => 20, -ipady => 10);
$text = "Disable Exit";
$mw->Button(-textvariable => \$text, -command => sub{
if( ($exit_b->configure(-state))[-1] eq "disabled" ){
$exit_b->configure(-state => "normal");
$text = "Disable Exit";
}
else{
$exit_b->configure(-state => "disabled");
$text = "Enable Exit";
}
})->pack;
MainLoop;
'
# TODO: Check if Unigraph is perl tk
# Create Menu Buttons (PTk,bind method)
perl -MTk -le '$mw=MainWindow->new; $mw->Button(-text => "Exit", -command => sub{exit})->pack(-side => "bottom", -fill => "both", -expand => 1); $f=$mw->Frame(-relief => "ridge", -borderwidth => 2)->pack(-side => "top", -expand => 1, -fill => "both")...
# Perk Tk Event Types (PTk,bind method)
ButtonPress (or Button)
ButtonRelease
Circulate
Colormap
Configure
Destroy
Enter
Expose
FocusIn
FocusOut
Gravity
KeyPress (or Key)
KeyRelease
Leave
# Optionmenu Example (Ptk,Appendix B)
# Pane Example (Ptk,Appendix B)
# Photo Example (Ptk,Appendix B)
# ProgressBar Example (Ptk,Appendix B)
# Radiobutton Example (Ptk,Appendix B)
# ROText Example (Ptk,Appendix B)
# Scale Example (Ptk,Appendix B)
# Table Example (Ptk,Appendix B)
# Text Example (Ptk,Appendix B)
# TextUndo Example (Ptk,Appendix B)
# Tiler Example (Ptk,Appendix B)
# TList Example (Ptk,Appendix B)
# TopLevel Example (Ptk,Appendix B)
# Tree Example (Ptk,Appendix B)
#############################################################
## Perl Modules - Tk::TextString, Tk::TextStrings
#############################################################
# Tie Text widget to store input as an entry or label would in "-variable" (PTk)
perl -MTk -le '{package P; sub TIESCALAR{my($c,$o)=@_; bless \$o,$c} sub FETCH{my($s)=@_; $$s->get("1.0", "end")} sub STORE{my($s,$v)=@_; $$s->delete("1.0", "end"); $$s->insert("end", $v)} } $mw=MainWindow->new; $t=$mw->Text->pack; tie $v, "P", $t; $...
# Tie Text widget to -variable. Set value with button or entry (PTk)
perl -MTk -le '{package P; sub TIESCALAR{my($c,$o)=@_; bless \$o,$c} sub FETCH{my($s)=@_; $$s->get("1.0", "end")} sub STORE{my($s,$v)=@_; $$s->delete("1.0", "end"); $$s->insert("end", $v)} } $mw=MainWindow->new; $t=$mw->Text->pack; tie $v, "P", $t; $...
# Example of new TextString Mega-Widget (PTk,tie,user module)
perl -MTk -MTk::TextString -w -le '$mw=MainWindow->new; $mw->TextString(-variable => \$v)->pack; $mw->Entry(-textvariable => \$v)->pack(-side => "left"); $mw->Button(-command => sub{print "[$v]"})->pack(-side => "left"); MainLoop'
# Scolled multiple text boxes through multiple -variables (PTk,tie,user module)
perl -MTk -MTk::TextString -w -le '%d=qw(-side left); $mw=MainWindow->new; @f=map{$mw->Frame->pack} 1..3; @t=map{my $v; $f[0]->TextString(-height => 2, -variable => \$v)->pack(%d); \$v} @f; $f[1]->Entry(-textvariable => $_)->pack(%d) for @t; $f[2]->B...
# Scolled multiple text boxes through single -variable (PTk,tie,user module)
perl -MTk -MTk::TextStrings -w -le '%d=qw(-side left); $mw=MainWindow->new; @f=map{$mw->Frame->pack} 1..3; @t=map{$f[0]->TextStrings(-height => 2, -variable => \$v)->pack(%d); \$v} @f; $f[1]->Entry(-textvariable => $_)->pack(%d) for @t; $f[2]->Button...
# Can text widget and entry widget are synced (PTk, tie,user module)
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: 1
valid: 1
SV = PV(0xb400007634f7a0b0) at 0xb400007634f89f98
REFCNT = 2
FLAGS = (POK,pPOK,UTF8)
PV = 0xb4000074f4f7fd30 "\xC3\xA4\xC3\xB6\xC3\xAB"\0 [UTF8 "\x{e4}\x{f6}\x{eb}"]
CUR = 6
LEN = 10
#################
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:
valid: 1
SV = PV(0xb400007c1f6780e0) at 0xb400007c1f684f98
REFCNT = 2
FLAGS = (POK,pPOK)
PV = 0xb400007aef66c2e0 "\xC3\x83\xC2\xA4\xC3\x83\xC2\xB6\xC3\x83\xC2\xAB"\0
CUR = 12
LEN = 24
#################
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: 1
valid: 1
SV = PV(0xb4000076231fb0b0) at 0xb400007623207f68
REFCNT = 2
FLAGS = (POK,pPOK,UTF8)
PV = 0xb4000074f31f6910 "\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
#################
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:
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::LibXML
#############################################################
# Parse and find specific nodes/elements in an xml file
# "//Page" means to look recursively down for a "Page" element
perl -MXML::LibXML -le '$d=XML::LibXML->load_xml(location => "my.xml"); print "$_\n\n" for $d->findnodes("//Page")'
# Parse xml file. Find all "PageTable" elements
# Select all PageTableProperty inside.
# Print out the value of the PageTableName (Use @ to find an attribute instead of a value)
# Print out the value (using ->to_literal)
perl -MXML::LibXML -le '$d=XML::LibXML->load_xml(location => "my.xml"); for($d->findnodes("//PageTable")){ ($p)=$_->findnodes("PageTableProperty"); print map $_->to_literal, $p->findnodes("\@PageTableName") }' | head
# Parse xml file. Find all "PageTable" elements
# findvalue is like findnode and then to_literal. Use it when you expect a single node
perl -MXML::LibXML -le '$d=XML::LibXML->load_xml(location => "my.xml"); for($d->findnodes("//PageTable")){ ($p)=$_->findnodes("PageTableProperty"); print $p->findvalue("\@PageTableName") }'
#
# Same thing but using getAttribute() DOM method.
perl -MXML::LibXML -le '$d=XML::LibXML->load_xml(location => "my.xml"); for($d->findnodes("//PageTable")){ ($p)=$_->findnodes("./PageTableProperty"); print $p->getAttribute("PageTableName") }'
#
# Can also use the tied hash accessing approach $p->{ATTRIBUTE}
perl -MXML::LibXML -le '$d=XML::LibXML->load_xml(location => "my.xml"); for($d->findnodes("//PageTable")){ ($p)=$_->findnodes("PageTableProperty"); print $p->{PageTableName} }'
# Parse xml file. Find all "PageTable" elements
# Print only the actuator page
perl -MXML::LibXML -le '$d=XML::LibXML->load_xml(location => "my.xml"); for($d->findnodes("//PageTable")){ ($p)=$_->findnodes("./PageTableProperty"); $v=$p->findvalue("\@PageTableName"); print if $v eq "ACTUATOR" }'
# Process HTML using XML::LibXML
# Does not load badly formated files without these options:
# recover
# suppress_errors
perl -MXML::LibXML -le '$d=XML::LibXML->load_html(location => "index.html", recover => 1, suppress_errors => 1); print $d'
# XML Process big files. Save memory
perl -MXML::LibXML::Reader -le '$d=XML::LibXML::Reader->new(location => "xml"); printf "%-10s %-10s %-10s %-10s\n", $d->nodeType, $d->depth, $d->name, $d->getAttribute("code") while $d->read'
# Pull out parts of of a list
perl -MXML::LibXML -le '$d=XML::LibXML->load_html(location => "OSRS", recover => 1, suppress_errors => 1); @t = $d->findnodes(q(//table[@class="wikitable infobox"])); @t = grep { $_->findvalue(q(tr[th/a/@title="Members"]/td)) =~ /No/} @t; print for @...
# Issues with XML::LibXML. Cannot parse control characters (except \n or \r)
perl -MXML::LibXML -E 'my $v = XML::LibXML->load_xml( string => "<div>\f</div>")'
#
# HTML::Entities does not help.
perl -MXML::LibXML -MHTML::Entities -E 'my $v = XML::LibXML->load_xml( string => encode_entities("<div>\f</div>", "\f"))'
#
# Same:
perl -MXML::LibXML -E 'my $v = XML::LibXML->load_xml( string => "<div></div>")'
#############################################################
## 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'
#############################################################
## Perl Book - Learning Perl Examples
#############################################################
# Exercise 2.1 (Learning Perl)
perl -le '$r=12.5; $pi=3.141592654; $c=2*$r*$pi; print $c'
# Exercise 2.2 (Learning Perl)
perl -le 'print "Enter radius: "; $r=<STDIN>; $pi=3.141592654; $c=2*$r*$pi; print $c'
# Exercise 2.3 (Learning Perl)
perl -le 'print "Enter radius: "; $r=<STDIN>; if($r < 0){ $r = 0 } $pi=3.141592654; $c=2*$r*$pi; print $c'
# Exercise 2.4 (Learning Perl)
perl -le 'print "Enter Num1: "; chomp($num1=<STDIN>); print "Enter Num2: "; chomp($num2=<STDIN>); print "$num1 * $num2 = ", ($num1 * $num2)'
# Exercise 2.5 (Learning Perl)
perl -le 'print "Enter String: "; chomp($string=<STDIN>); print "Enter num: "; chomp($num=<STDIN>); print $string x $num'
#############################################################
## Perl6 Programs (Rakudo)
#############################################################
# Setup/install/compile rakudo (perl6)
# 1. Get Latest
rm -f ~/rakudo/setup/index.html*
read -sp "Password: " PASSWORD
echo "$PASSWORD" | perl -ple 's/(\W)/ sprintf "%%%x", ord($1) /eg'
wget http://rakudo.org/downloads/star/ -P ~/rakudo/setup
ls ~/rakudo/setup/index.html | perl -MHTML::Tree -lne 'print HTML::Tree->new_from_file($_)->look_down(class => "ext-gz")->attr("href")'
basename `$LATEST`
# Setup/install/compile rakudo (perl6)
# 2. Download
read -sp "Password: " PASSWORD
echo "$PASSWORD" | perl -ple 's/(\W)/ sprintf "%%%x", ord($1) /eg'
wget http://rakudo.org/downloads/star/$LATEST -P ~/rakudo/setup
# Setup/install/compile rakudo (perl6)
# 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
#############################################################
## Perlbrew
#############################################################
# Restore original perl environment
# https://stackoverflow.com/questions/25188575/switching-to-the-system-perl-using-perlbrew
perlbrew off # only for this session (terminal)
perlbrew switch-off # permanently
# Using the shebang line with perlbrew (-S to pass in args)
#!/usr/bin/env perl
#!/usr/bin/env -S perl -l
# Install with thread support.
perlbrew install perl-5.38.2 --thread
# Install multiple versions with and without thread support.
perlbrew install-multiple 5.38.2 blead --both thread
perlbrew switch perl-5.38.2-thread-multi
perl -V:'use.*thread.*'
# Upgrade current perl version.
perlbrew upgrade-perl
# Upgrade perlbrew
perlbrew self-upgrade
perlbrew version
# Upgrade cpanm
perlbrew install-cpanm
# Cleanup downloaded files.
perlbrew clean
#############################################################
## Performance Testing - General
#############################################################
# Performance Testing - Ensures the system meets performance criteria like speed and responsiveness.
# Load Testing - Checks system behavior under expected user load.
# Stress Testing - Determines the system's breaking point by pushing it beyond normal capacity.
# Scalability Testing - Assesses how well the system scales with increased workload.
# Spike Testing - Examines how the system handles sudden spikes in load.
# Volume Testing - Verifies system performance with varying amounts of data.
#############################################################
# Step 1 – Prerequisites:
sudo apt install -y unzip xvfb libxi6 libgconf-2-4
sudo apt install default-jdk
#
# Step 2 – Install Google Chrome:
sudo curl -sS -o - https://dl-ssl.google.com/linux/linux_signing_key.pub | apt-key add
sudo bash -c "echo 'deb [arch=amd64] http://dl.google.com/linux/chrome/deb/ stable main' >> /etc/apt/sources.list.d/google-chrome.list"
sudo apt update
sudo apt install google-chrome-stable
#
# Step 3 – Installing ChromeDriver:
google-chrome --version
#
# Download same version:
# https://chromedriver.chromium.org/downloads
cd ~/Downloads
unzip chromedriver*.zip
#
# Move it:
sudo mv chromedriver /usr/bin/chromedriver
sudo chown root:root /usr/bin/chromedriver
sudo chmod +x /usr/bin/chromedriver
#
# Step 4 – Download Required Jar Files:
# Create selenium service
#
sudo cp ~/my/git/srto/selenium/setup/_etc_systemd_system_selenium.service /etc/systemd/system/selenium.service
sudo vi /etc/systemd/system/selenium.service
+ [Unit]
+ Description=Selenium Server
+
+ [Service]
+ EnvironmentFile=-/etc/default/selenium
+ User=<USER>
+ Group=<USER>
+ Environment="PERL5OPT=-d:NYTProf" "NYTPROF='trace=0:start=no:addpid=1:slowops=0'"
+ Environment=DISPLAY=:1
+ ExecStart=/usr/bin/java -Dwebdriver.chrome.driver=/usr/bin/chromedriver -jar /usr/local/lib/selenium/current.jar $SELENIUM_OPTS
+ SuccessExitStatus=143
+
+ [Install]
+ WantedBy=graphical.target
# Selenium service environment file
#
sudo cp ~/my/git/srto/selenium/setup/_etc_default_selenium /etc/default/selenium
sudo vi /etc/default/selenium
+ SELENIUM_OPTS="-role standalone -debug"
# 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
echo 'Unattended-Upgrade::Allowed-Origins:: "LP-PPA-mozillateam:${distro_codename}";' | sudo tee /etc/apt/apt.conf.d/51unattended-upgrades-firefox
#############################################################
## SQLite3 Database
#############################################################
# Install sqlite on Unix (after in zipping the amalgamation file. make sure these 3 are present:
# shell.c, sqlite3.c, sqlite3.h). rename to a.out to sqlite3
# (database, sqlite3)
gcc shell.c sqlite3.c -lpthread -ldl
# View all the tables in a database (database, sqlite3)
sqlite3 my.db '.tables'
# Turn on column names on query results (database, sqlite3)
sqlite3 my.db '.explain on' 'select * from page_groups'
# Print database structure and data (database, sqlite3)
sqlite3 my.db '.dump'
# View current status/info (database, sqlite3)
sqlite3 my.db '.show'
# REFERENCES and FOREIGN KEYS are (database, sqlite3)
# used to ensure that the tables keys are valid since they
# are found in the foreign table.
# Output the results with a header and evenly spaced columns
sqlite3 my.db --header -column 'select * from my_table'
# Create a new database, table, and data (nathan)
sqlite3 my.db 'create table Users(name,date)'
sqlite3 my.db 'insert into Users values ("bob",20)'
sqlite3 my.db 'insert into Users values ("Joe",25)'
sqlite3 my.db '.explain on' '.width auto' 'select * from Users'
# Case Insensitive Search in SQL query
SELECT ... FROM ... WHERE ... ORDER BY name COLLATE NOCASE ASC LIMIT 5
# Master sqlite table (.tables)
if (table == "") {
query = m_interface->prepare("SELECT name from sqlite_master"); // .tables
}
# View the .schema
else if (haveVerbose) {
query = m_interface->prepare("SELECT sql FROM sqlite_master WHERE name=:table"); // .schema
query.bind(":table", table);
}
# View the columns
+ # ['TAB','CTRL','ALT','LEFT','DOWN','RIGHT','PGDN','BKSP'] \
+ # ]
+
+ extra-keys = [[ \
+ 'ESC', \
+ 'TAB', \
+ 'UP', \
+ 'DOWN', \
+ 'LEFT', \
+ 'RIGHT', \
+ 'CTRL', \
+ 'ALT', \
+ 'DEL' \
+ ]]
# Check termux kernel settings.
sudo zcat /proc/config.gz
# Install arm-none-eabi (termux)
git clone git@github.com:poti1/arm-none-eabi.git
cd arm-none-eabi
make
# This variable is set when a new session is created.
# This library intercepts/changes calls to:
# /usr/bin/perl to instead code from the termux folder
echo $LD_PRELOAD
/data/data/com.termux/files/usr/lib/libtermux-exec.so
#############################################################
## Ubuntu - Hard Drive Encryption - Detailed
#############################################################
# Ubuntu hard drive encryption.
# 1. Create the encrypted partition:
sudo cryptsetup luksFormat /dev/sda
#
# Verify header.
sudo cryptsetup luksDump /dev/sda
# Ubuntu hard drive encryption.
# 2. Map the encrypted container:
sudo cryptsetup luksOpen /dev/sda secret-container
# Ubuntu hard drive encryption.
# 2a. Wipe the partition (optional):
sudo shred -vfz /dev/mapper/secret-container
# Ubuntu hard drive encryption.
# 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.
#
# You could also mount it under /home, but then you will have
# all user's home directories in one encrypted drive - that
# means all of them need to know the partition's password to open it on boot.
# Originally thought these were also necessary for an external hard drive.
# Appear to work without the lines.
#
sudo vi /etc/crypttab
# <name> <device> <password> <options>
mnt-usb-crypt UUID=<device-uuid> /path/to/key luks,noauto
#
# Need to run after updating cryptab:
sudo update-initramfs -u -k all
#
sudo vi /etc/fstab
#
# <file system> <dir> <type> <options> <dump> <pass>
/dev/mapper/mnt-usb-crypt /mnt/usb btrfs defaults,noauto,x-systemd.automount 0 2
# Unable to mount the unencrypted harddrive.
# Error mentions mount: wrong fs type, bad option, bad superblock.
#
# See disks:
lsblk
#
# If you can see your drive thats good.
# Run this to see if the system can use it:
sudo fdisk -l
#
# Run this command to attempt to repair bad superblocks on the drive.
sudo xfs_repair /dev/mapper/srto_backup
#
# Mount again after repair is done:
sudo mount /dev/mapper/srto_backup /media/<USER>/SRTO_BACKUP
# Restore corrupted USB drive.
# Warning: could not erase sector 2: Input/output error.
sudo dd if=/dev/zero of=/dev/sdb bs=1M count=40
#
# Disk repair/recovery tool.
sudo apt install testdisk
#############################################################
## Ubuntu - Hard Drive Encryption - Simple
#############################################################
# Ubuntu hard drive encryption. (simple)
#
# Ubuntu prevent auto suspend when closing the lid.
sudo apt install gnome-tweaks
# Start Tweaks -> General
#############################################################
## Ubuntu - X-Server
#############################################################
# On Ubuntu there are 2 X-Servers available during login:
- Wayland
- Xorg
# Wayland is newer and to use screen sharing (share,jitsi) in
chrome enable this:
chrome://flags/#enable-webrtc-pipewire-capturer
# Xorg should be avoided since it can cause a black screen on lock screen
(at least if an extra monitor is connected).
#############################################################
## Ubuntu - Desktop/Tasklist App
#############################################################
# Sample .desktop file to add xair as a favorite program.
cat xair.desktop
[Desktop Entry]
Encoding=UTF-8
Version=1.0
Type=Application
Name=XAIR
# If file name is to be renamed, also probably need to update this class,
# (as is done now).
# Run:
# xprop WM_CLASS # WM_CLASS(STRING) = "X-AIR-Edit", "X-AIR-Edit"
StartupWMClass=X-AIR-Edit
Exec=/home/tim/git/xair/software/latest/RUN.sh
Icon=/home/tim/git/xair/software/latest/xair.png
#############################################################
## VBA Regex
#############################################################
# Regex for validating input on database
cat data | add_color -r '(?x) ^ (?! ^( (ALLENGINES|ASAPPLICABLE|PW\d+\w+-?\w+)(,|$))+ ((Except:)? (\d{6}-\d{6}|\d{6}) (,|$) )* $ ) .*'
#############################################################
## Vim Strings
#############################################################
# 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>
#############################################################
## Vim Quitting
#############################################################
# Exit, saving changes (Vim)
:x
# Exit as long as there have been no changes (Vim)
:q
# Exit and save changes if any have been made (Vim)
ZZ
# Exit and ignore any changes (Vim)
:q!
#############################################################
## Vim Variables
#############################################################
# Do substitution on a string or variable (vim)
let new_variable s = ubstitute("My::Long::Package", "::", "/", "g")
let old_variable = "My::Long::Package"
let new_variable = substitute(old_variable, "::", "/", "g")
# Check if a string or variable contains a pattern (vim)
echo "My::Package" =~ "::" # 1
let var = "My::Package"
if var =~ "::"
echo "Got a perl package"
endif
#############################################################
## Vim File Operations
#############################################################
# Check if a file is readable (vim,exists)
if filereadable(l:filename) == 1
execute "edit" l:filename
else
echohl WarningMsg | echo "File does not exist: " . l:filename | echohl None
endif
#############################################################
## Vim Funtions
#############################################################
## Vim Abbreviations
#############################################################
# Create an abbreviation (Vim)
# Expands in insert mode after typing "TIM "
:ab TIM Time Is Money
# View all abbreviations set (Vim)
:ab
# View value for an abbreviation (Vim)
:ab TIM
# Remove abbreviation (Vim)
:unab TIM
#############################################################
## Vim Map Command Keys
#############################################################
# View mapped commands (Vim)
:map
# Create a mapping of commands for a particular key (Vim)
# Key 'q' will go down 5 lines and make a new line
:map q 5jo
# Reverse this and the following word (Vim,2 words,demo)
:map r wBdwelpBB
# Move word to the right (Vim)
:map gr "xdiwdwep"xpb
# Move word to the left (Vim)
:map gl lbgr
# Put html markers around a word (Vim)
:map + i<I>^[ea</I>^[
# Make the backslash a map leader (Vim,portable)
# Use leaders for global plugins.
:let mapleader = "\\"
:nnoremap <leader>d dd # Same as:
:nnoremap \d dd
# Make the dash a map local leader (Vim,portable)
# 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.
q # Stop recording.
# View recorded macros (Vim)
# ^[ is ESC key
:reg
:reg a
# Replay a macro (Vim,run)
@a
# Replay last macro (Vim,run)
@@
# Repeat movement and commands (Vim)
qq;.q # next, repeat command
11@q # run 11 times
# Number a list of lines (Vim)
:let @c=0 # set value of register (preload)
:let @n=0i^R=^Rc+1^M. ^[0"cywj^[ # will not work with control characters
# Run macro commands in parallel (Vim)
:let @a='0f.r)w~' # load macro
<Shirt> + V + G # Select current line to end
:normal @a # run macro on lines
# Select desired lines in file and run macro on them (Vim,global)
:g /^sched_args/ :normal @c
# Append to existing register (Vim,typo)
qa # start original macro
... # commands
q # stop recording
qA # Captial means append to register "a"
... # Fix typo
q # End
# Indent the description section in primitives_doc file (Vim)
# This commands finds any problems
:g/^\v Syntax:.*\n\n/ .+2,/^\v [a-zA-Z]+:/-2p
#
# This will transform.
# 1. Find all "Syntax:" lines.
# 2. Assume next is blank, so start 2 lines down "+2".
# 3. Search for the next section and end 2 above that "-2".
# 4. Strip any leading space and replace with 6 spaces.
# 5. Strip trailing whitespace.
g/^\v Syntax:.*\n\n/ .+2,/\v^ [a-zA-Z]+:/-2 s/^\v\s*(\S+)@=/ / | s/\s\+$//
( run in 2.304 seconds using v1.01-cache-2.11-cpan-800906f7e73 )