The Perl Programming Guide

#!/usr/local/bin/perl      # FreeBSD: pkg Perl lives here
#!/usr/bin/env perl         # Portable: searches $PATH

perl myscript.pl       # Run
perl -c myscript.pl    # Syntax check only
perl -w myscript.pl    # Warnings
chmod +x s.pl && ./s.pl  # Run via shebang

my $name = "Alice";  my $age = 30;  my $pi = 3.14159;
my $city = "Sydney";
print "Hello $city!\n";       # Interpolates
print 'Literal $city\n', "\n"; # Single-quotes: no interpolation
print defined(undef) ? "defined" : "undef";

my $s = "Hello" . ", " . "World!";  # . = concatenation
my $l = "-" x 40;                    # x = repetition

length("hello")            # 5
uc("hi")                   # "HI"
ucfirst("perl")            # "Perl"
substr("Submarine", 3, 4)  # "marin"
index("Submarine", "arin") # 4
chomp($s);                 # Remove trailing newline

# sprintf
sprintf("%08d", 42)        # "00000042"
sprintf("%.4f", 3.14159)   # "3.1416"
sprintf("%-10s|","hi")     # "hi        |"

# String comparison: eq ne lt gt le ge cmp

use POSIX qw(floor ceil);
my $hex=0xFF; my $bin=0b1010; my $big=1_000_000;
# + - * /  %  **  ++  --
# == != < > <= >=  <=> (spaceship)
abs(-5)    # 5
int(3.9)   # 3
sqrt(144)  # 12
floor(3.7) # 3   ceil(3.2) # 4
my @s = sort { $a <=> $b } (5,2,9,1);

use List::Util qw(sum min max first any all);
my @c = ("red","green","blue");
my @r = (1..10);
my @w = qw(banana apple cherry);
$c[0]         # "red"      $c[-1] # "blue"
scalar @c     # 3          $#c    # 2

push @c,"yellow";   my $v=pop @c;
unshift @c,"white"; my $f=shift @c;

my @ev = grep { $_ % 2 == 0 } @r;
my @d2 = map  { $_ * 2 }      @r;
my @as = sort { $a <=> $b }   @r;

sum(@r)  # 55   min(@r)  # 1   max(@r) # 10
join(", ",@c)         # "red, green, blue"
split(/,/,"a,b,c")    # ("a","b","c")

my %p = (name=>"Bob", age=>25, city=>"Austin");
$p{email} = "b@x.com";
delete $p{city};
exists $p{name};   # Boolean
foreach my $k (sort keys %p) { printf "%s: %s\n",$k,$p{$k} }

# Frequency count
my %freq; $freq{$_}++ for @data;
# Unique
my %seen; my @u = grep { !$seen{$_}++ } @data;

if    ($n > 90) { ... }
elsif ($n > 80) { ... }
else            { ... }
unless ($err)   { ... }     # Opposite of if
print "ok\n" if $flag;      # Postfix
my $r = ($n>0) ? "pos" : "neg";  # Ternary
my $v = $input // "default";      # Defined-or
open(my $fh,"<",$f) or die "$!";

while ($i < 10) { $i++ }
foreach my $item (@arr) { print "$item\n" }
print "$_ " for 1..10;    # Postfix
next;   # Skip   last;  # Break
OUTER: for my $i (1..3) {
    for my $j (1..3) { next OUTER if $j==2 }
}
my @sq = map  { $_ ** 2 } 1..8;
my @od = grep { $_ % 2  } 1..10;

if ($s =~ /pat/i)  { }     # Match
if ($s !~ /pat/)   { }     # Negated
$s =~ s/old/new/g;          # Substitute global
$s =~ tr/a-z/A-Z/;          # Transliterate

# Capture groups
if ($d =~ /(\d{4})-(\d{2})-(\d{2})/) {
    my ($y,$m,$d2) = ($1,$2,$3);
}
# Named: $+{year}   Global: ($s=~/(\d+)/g)
# Extended /x — add comments in the regex

sub greet { my ($n,$g)=@_; $g//="Hello"; "$g, $n!" }

# Closure factory
sub make_mult { my($f)=@_; sub { $_[0]*$f } }
my $dbl = make_mult(2);
print $dbl->(7);    # 14

# Dispatch table
my %ops = (add=>sub{$_[0]+$_[1]}, mul=>sub{$_[0]*$_[1]});
$ops{add}->(10,3);  # 13

# Recursive
sub fact { $_[0]<=1 ? 1 : $_[0]*fact($_[0]-1) }

my $ar = [1,2,3];       # Anon array ref
my $hr = {a=>1};        # Anon hash ref
$ar->[0]  $hr->{a}

my @team = (
    {name=>"Alice",role=>"dev",level=>5},
    {name=>"Bob",  role=>"ops",level=>3},
);
my @sorted = sort { $b->{level} <=> $a->{level} } @team;
my @devs   = grep { $_->{role} eq "dev" } @team;

use Data::Dumper; print Dumper(\@team);

open(my $fh,"<",$f)  or die "$!";  # Read
open(my $fh,">",$f)  or die "$!";  # Write
open(my $fh,">>",$f) or die "$!";  # Append

while (my $line=<$fh>) { chomp $line; ... }
my $all = do { local $/; <$fh> };  # Slurp

# -e exists  -f file  -d dir  -r readable  -s size

die "Fatal\n"; warn "Warning\n";
eval { die "oops\n" };
print "Caught: $@" if $@;
eval { die {code=>404,msg=>"Not found"} };
if (ref $@ eq 'HASH') { printf "%d: %s\n",$@->{code},$@->{msg} }

package Animal;
sub new { my($cl,%a)=@_; bless {name=>$a{name}//"?",sound=>$a{sound}//"..."},$cl }
sub speak { printf "%s says: %s\n",$_[0]->{name},$_[0]->{sound} }

package Dog;
use parent 'Animal';
sub new { my($cl,%a)=@_; $a{sound}="Woof"; $cl->SUPER::new(%a) }
sub fetch { print "$_[0]->{name} fetches!\n" }

package main;
my $d = Dog->new(name=>"Rex");
$d->speak;  $d->fetch;
$d->isa("Animal");   # 1 (true)

use List::Util qw(sum min max first any all reduce);
sum(1..10)               # 55
reduce { $a*$b } 1..5    # 120

# Schwartzian Transform
my @bl = map  { $_->[0] }
         sort { $a->[1] <=> $b->[1] }
         map  { [$_,length($_)] }
         @words;

use Getopt::Long;
GetOptions(
    "verbose|v"  => \$verbose,
    "output|o=s" => \$output,
    "count|n=i"  => \$count,
) or die "Usage: $0 [--verbose] [--output FILE]\n";

macOS Host                         Lima VM (FreeBSD 16)
──────────────────────────────────────────────────────
XQuartz.app   ←── X11 protocol ─── perl gui_04_app.pl
(Display :0)      (over SSH -X)    Perl/Tk → X11 calls

#!/usr/local/bin/perl
use strict; use warnings; use Tk;
my $mw = MainWindow->new;
$mw->title("My App");
$mw->geometry("400x300");
$mw->Label(-text => "Hello, FreeBSD!")->pack;
MainLoop;   # Event loop — never returns

my $msg = "Hello";
$mw->Label(-textvariable => \$msg)->pack;
$msg = "Updated!";    # Label shows "Updated!" immediately

# pack — flow layout
$w->pack(-side=>"top", -fill=>"x", -expand=>1, -padx=>5);

# grid — table layout (best for forms)
$w->grid(-row=>0, -column=>1, -sticky=>"ew", -padx=>5);
$parent->gridColumnconfigure(1, -weight=>1);

# place — absolute
$w->place(-relx=>0.5, -rely=>0.5, -anchor=>"center");

$w->bind("",  \&on_click);
$w->bind("",    \&on_enter);
$canvas->bind("", sub {
    my $e = $canvas->XEvent;
    printf "x=%d y=%d\n", $e->x, $e->y;
});

# FreeBSD/X11: standard modifier is Control, not Meta/Cmd
$mw->bind("", \&save);      # Ctrl+S
$mw->bind("", \&open_file); # Ctrl+O
$mw->bind("", \&undo);      # Ctrl+Z
$mw->bind("", sub { exit }); # Ctrl+Q

# Meta on X11 maps to the Alt key
$mw->bind("",  sub { exit });  # Alt+F4

sub tick {
    update_clock();
    $mw->after(1000, \&tick);   # Re-schedule every second
}
tick();   # Start the clock

my $mb = $mw->Menu; $mw->configure(-menu=>$mb);
my $file = $mb->cascade(-label=>"File", -tearoff=>0);
$file->command(-label=>"Open…", -accelerator=>"Ctrl+O", -command=>\&open_f);
$file->command(-label=>"Quit",  -accelerator=>"Ctrl+Q", -command=>sub{exit});

my $ans = $mw->messageBox(-type=>"YesNo",-message=>"Sure?");
my $f   = $mw->getOpenFile(-filetypes=>[["Text",".txt"],["All","*"]]);
my $c   = $mw->chooseColor(-initialcolor=>"#2060c0");

my $cv = $mw->Canvas(-width=>600,-height=>400,-background=>"white")
    ->pack(-fill=>"both",-expand=>1);

$cv->createLine(10,10,200,100,  -fill=>"blue",-width=>2);
$cv->createRectangle(50,50,200,150, -fill=>"lightblue",-outline=>"navy");
$cv->createOval(250,50,400,200, -fill=>"yellow");
$cv->createText(300,250, -text=>"Hello!",-font=>"Helvetica 16 bold");

$cv->move($id,10,5);                     # Move
$cv->itemconfigure($id,-fill=>"red");    # Recolour
$cv->delete("all");                      # Clear

#!/usr/local/bin/perl
use strict; use warnings; use Tk;

my ($modified,$status) = (0,"Ready");
my $mw = MainWindow->new;
$mw->title("My App"); $mw->geometry("800x600");
$mw->protocol("WM_DELETE_WINDOW", \&on_quit);

build_menu($mw); build_body($mw);

$mw->bind("", \&cmd_save);  # Ctrl+S — FreeBSD/X11
$mw->bind("", \&on_quit);   # Ctrl+Q

MainLoop;

sub on_quit {
    if ($modified) {
        my $a = $mw->messageBox(-type=>"YesNoCancel",-message=>"Save?");
        return if $a eq "Cancel";
        cmd_save() if $a eq "Yes";
    }
    exit;
}

PORT=$(limactl list --format '{{.SSHLocalPort}}' experimental/freebsd-16)
KEY=~/.lima/_config/user

# macOS → VM
scp -P $PORT -i $KEY *.pl 127.0.0.1:~/

# VM → macOS
scp -P $PORT -i $KEY 127.0.0.1:~/output.txt ~/Downloads/

# Sync directory with rsync
rsync -av -e "ssh -p $PORT -i $KEY" ./scripts/ 127.0.0.1:~/scripts/

open -a XQuartz                 # Start XQuartz on macOS
echo $DISPLAY                   # Check: should be localhost:10.0
export DISPLAY=localhost:10.0   # Set manually if empty
pkg install xterm && xterm &    # Test X11 with a simple window

-font => "Helvetica 13"           # Always available (X11 core)
-font => "Courier 12"             # Always available
-font => "DejaVu Sans 12"         # pkg install dejavu-ttc
-font => "DejaVu Sans Mono 12"    # Excellent monospace

pkg update                    # Refresh catalogue
pkg install p5-Tk             # Install package
pkg search perl               # Search
pkg info perl5                # Details
pkg upgrade                   # Upgrade all