The Perl Programming Guide

#!/usr/bin/perl
# On macOS with Homebrew Perl (recommended):
#!/usr/bin/env perl

use strict;
use warnings;

perl myscript.pl               # Run normally
perl -c myscript.pl            # Syntax check only (does not run)
perl -w myscript.pl            # Enable warnings from command line
perl -e 'print "Hello\n";'     # One-liner

# Single-line comment — the only comment syntax in Perl

=pod
Multi-line POD (Plain Old Documentation) block.
Acts as a block comment and can also generate documentation.
=cut

my $name    = "Alice";       # String
my $age     = 30;            # Integer
my $pi      = 3.14159;       # Float
my $flag    = 1;             # Boolean-like (1 = true, 0/"" = false)
my $nothing = undef;         # Undefined value

my $city = "San Francisco";
print "Welcome to $city!\n";        # Interpolates → Welcome to San Francisco!
print 'No interpolation: $city\n';  # Literal → No interpolation: $city\n

if (defined $nothing) { print "defined\n" }
else                  { print "undef\n"   }

my $full = "Hello" . ", " . "World!";   # Concatenation with .
my $line = "-" x 40;                     # Repetition with x
my $arr  = (0) x 5;                      # Array of five zeros

my $text = <<END;
Line one
Line two
Line three
END

my $hex = 0xFF;        # 255 — hexadecimal
my $oct = 0755;        # 493 — octal
my $bin = 0b1010;      # 10  — binary
my $big = 1_000_000;   # Underscores for readability

use POSIX qw(floor ceil);
abs(-5)       # 5
int(3.9)      # 3  (truncates toward zero)
sqrt(16)      # 4
floor(3.7)    # 3
ceil(3.2)     # 4
log(exp(1))   # 1  (natural log)

srand(42);                    # Seed the random number generator
my $roll = int(rand(6)) + 1;  # Die roll: 1–6

my @colors = ("red", "green", "blue");
my @range  = (1..10);               # Range operator
my @words  = qw(one two three);     # Quote-words shorthand

$colors[0]      # "red"
$colors[-1]     # "blue"  (negative = from end)
scalar @colors  # 3       (element count)
$#colors        # 2       (last index)

push    @arr, $val;      # Add to end
my $v = pop  @arr;       # Remove from end
unshift @arr, $val;      # Add to front
my $v = shift @arr;      # Remove from front
splice(@arr, $idx, $n);  # Remove n elements at index

# grep — filter (returns elements where block is true)
my @evens = grep { $_ % 2 == 0 } @nums;

# map — transform (returns one result per element)
my @doubled = map { $_ * 2 } @nums;

# sort — alphabetical by default
my @alpha = sort @words;
my @numsort = sort { $a <=> $b } @nums;   # Numeric
my @bylen   = sort { length($a) <=> length($b) } @words;

# join and split
my $csv   = join(",", @words);
my @parts = split(/,/, $csv);

my %person = (
    name  => "Bob",      # fat comma auto-quotes the left side
    age   => 25,
    city  => "Austin",
);

$person{email} = "b@x.com";   # Add key
delete $person{city};           # Remove key
exists $person{name};           # Check if key present (boolean)
defined $person{age};           # Check if value is defined

# Iterate sorted
foreach my $key (sort keys %person) {
    print "$key: $person{$key}\n";
}

my @info = @person{qw(name city)};        # Get multiple values at once
@person{qw(x y)} = (10, 20);             # Set multiple values

# qw() — Quote Words: creates a list without commas or quotes
my @days = qw(Mon Tue Wed Thu Fri Sat Sun);

# Frequency count
my %freq;
$freq{$_}++ for @data;

# Unique elements (preserving order)
my %seen;
my @unique = grep { !$seen{$_}++ } @data;

# Group-by
my %by_city;
push @{ $by_city{$_->{city}} }, $_ for @people;

# if / elsif / else
if    ($score >= 90) { print "A\n" }
elsif ($score >= 80) { print "B\n" }
elsif ($score >= 70) { print "C\n" }
else                 { print "F\n" }

# unless — runs when condition is FALSE
unless ($logged_in) { die "Access denied\n" }

# Postfix (statement modifier) form
print "positive\n" if $n > 0;
print "not zero\n" unless $n == 0;

# Ternary operator
my $label = ($n > 0) ? "positive" : "non-positive";

# Defined-or — use $input if defined, else use "default"
my $val = $input // "default";

# Short-circuit control flow
open(my $fh, "<", $file) or die "Cannot open: $!";

# while — runs while condition is true
while ($i < 10) { $i++ }

# until — runs while condition is FALSE
until ($done) { do_work() }

# C-style for
for (my $i = 0; $i < 10; $i++) { print "$i\n" }

# foreach — iterate over a list
foreach my $item (@array) { print "$item\n" }

# Postfix (one-liner)
print "$_\n" for @array;

# do...while — runs body at least once
do { $attempts++ } while ($attempts < 3);

for my $n (1..20) {
    next if $n % 2 == 0;    # Skip even numbers
    last if $n > 9;          # Stop after 9
    print "$n ";             # Prints: 1 3 5 7 9
}

# Loop labels for nested loop control
OUTER: for my $i (1..3) {
    for my $j (1..3) {
        next OUTER if $j == 2;   # Jump to outer loop
        print "($i,$j) ";
    }
}

# Match operator m//
if ($str =~ /pattern/)  { ... }    # Does $str match?
if ($str !~ /pattern/)  { ... }    # Does $str NOT match?

# Substitution operator s///
$str =~ s/old/new/;       # Replace first occurrence
$str =~ s/old/new/g;      # Replace all (global)
$str =~ s/old/new/gi;     # Global + case-insensitive

# Transliteration tr///
$str =~ tr/a-z/A-Z/;      # Convert all lowercase to uppercase
my $n = ($str =~ tr/e//); # Count occurrences of 'e'

# Numbered captures — $1, $2, $3 ...
if ("2024-05-04" =~ /(\d{4})-(\d{2})-(\d{2})/) {
    my ($year, $month, $day) = ($1, $2, $3);
}

# Named captures — $+{name}
if ($str =~ /(?<year>\d{4})-(?<month>\d{2})/) {
    print $+{year};
}

# Global match in list context — finds ALL matches
my @dates = ($text =~ /(\d{4}-\d{2}-\d{2})/g);

# Extended /x mode — add whitespace and comments for readability
my $valid = $email =~ /
    ^           # Start of string
    [\w.+\-]+   # Local part
    @           # At sign
    [\w\-]+     # Domain name
    (\.\w+)+    # One or more extensions
    $           # End of string
/x;

# Basic subroutine — arguments arrive in @_
sub greet {
    my ($name, $greeting) = @_;    # Always unpack @_ with my
    $greeting //= "Hello";         # Default value
    return "$greeting, $name!";
}

# Multiple return values
sub minmax {
    my @sorted = sort { $a <=> $b } @_;
    return ($sorted[0], $sorted[-1]);
}
my ($min, $max) = minmax(5, 2, 8, 1, 9);

# Named parameters via hash (best for 3+ args)
sub create_user {
    my (%args) = @_;
    my $name = $args{name} // "Anonymous";
    my $role = $args{role} // "user";
    return { name => $name, role => $role };
}
create_user(name => "Carol", role => "admin");

# Anonymous sub stored in a scalar
my $square = sub { return $_[0] ** 2 };
print $square->(5);    # 25

# Closure — captures outer variable $factor
sub make_multiplier {
    my ($factor) = @_;
    return sub { $_[0] * $factor };     # $factor is "closed over"
}
my $double = make_multiplier(2);
my $triple = make_multiplier(3);
print $double->(7);   # 14
print $triple->(7);   # 21

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

# Create references
my $aref = \@array;        # Ref to existing array
my $href = \%hash;         # Ref to existing hash
my $aref = [1, 2, 3];     # Anonymous array ref (most common)
my $href = {a => 1};      # Anonymous hash ref

# Arrow notation to dereference (preferred style)
$aref->[0]                 # Array element
$href->{key}               # Hash value
$cref->()                  # Call subroutine ref

my @team = (
    { name => "Alice", role => "dev", level => 5 },
    { name => "Bob",   role => "ops", level => 3 },
);

# Iterate
foreach my $member (@team) {
    printf "%-8s %s\n", $member->{name}, $member->{role};
}

# Sort, filter, transform
my @by_level = sort { $b->{level} <=> $a->{level} } @team;
my @devs     = grep { $_->{role} eq "dev" } @team;
my @names    = map  { $_->{name} } @team;

# Hash of arrays
my %by_role;
push @{ $by_role{$_->{role}} }, $_->{name} for @team;

# Deep nested — access with chained arrows
my $company = {
    depts => {
        eng => { head => "Alice", staff => [qw(Bob Carol)] },
    },
};
print $company->{depts}{eng}{head};          # Alice
push @{ $company->{depts}{eng}{staff} }, "Dave";

# Always use three-argument open
open(my $fh, "<",  $file) or die "Cannot open: $!";   # Read
open(my $fh, ">",  $file) or die "Cannot open: $!";   # Write
open(my $fh, ">>", $file) or die "Cannot open: $!";   # Append

# $! contains the OS error message on failure

# Read line by line (memory efficient)
while (my $line = <$fh>) {
    chomp $line;     # Remove trailing newline
    # process $line
}

# Slurp entire file into a string
my $content = do { local $/; <$fh> };

# Write
print $fh "Hello, file!\n";
printf $fh "Value: %05d\n", 42;
close($fh);

# File test operators
-e $f   # Exists?
-f $f   # Regular file?
-d $f   # Directory?
-r $f   # Readable?
-w $f   # Writable?
-s $f   # Size in bytes

use ModuleName;                        # Import all defaults
use ModuleName qw(func1 func2);       # Import specific functions
use ModuleName ();                     # Load but import nothing

# File: MyMath.pm
package MyMath;
use strict;
use warnings;
use Exporter qw(import);

our @EXPORT_OK = qw(square cube);

sub square { return $_[0] ** 2 }
sub cube   { return $_[0] ** 3 }

1;   # Must end with a true value!

# Usage:
use MyMath qw(square cube);
print square(4);   # 16

cpanm Module::Name        # With cpanminus (recommended)
cpan Module::Name         # With the built-in cpan client

die  "Fatal error\n";    # Terminates program, prints to STDERR
warn "Warning\n";        # Prints to STDERR, continues

# eval — catch exceptions (like try/catch)
eval {
    die "something failed!\n";
};
if ($@) {
    print "Caught: $@";    # $@ contains the error from last eval
}

# die with a structured object
eval {
    die { code => 404, msg => "Not found" };
};
if (ref $@ eq 'HASH') {
    printf "Error %d: %s\n", $@->{code}, $@->{msg};
}

# The or die pattern — most common file I/O idiom
open(my $fh, "<", $file) or die "Cannot open $file: $!";

package Animal;
use strict; use warnings;

sub new {
    my ($class, %args) = @_;
    my $self = {
        name  => $args{name}  // "Unknown",
        sound => $args{sound} // "...",
    };
    return bless $self, $class;   # bless ties the hash to the class
}

# Accessor methods
sub name  { $_[0]->{name}  }
sub sound { $_[0]->{sound} }
sub speak { printf "%s says: %s\n", $_[0]->name, $_[0]->sound }

package Dog;
use parent 'Animal';              # Inheritance

sub new {
    my ($class, %args) = @_;
    $args{sound} = "Woof";
    return $class->SUPER::new(%args);   # Call parent constructor
}
sub fetch { print "$_[0]->{name} fetches!\n" }

# Usage
package main;
my $dog = Dog->new(name => "Rex");
$dog->speak;             # Rex says: Woof
$dog->fetch;             # Rex fetches!
ref($dog);               # "Dog"
$dog->isa("Animal");     # 1 (true)

use List::Util qw(sum min max first any all reduce);

sum(1..10)                         # 55
min(5, 2, 8, 1)                    # 1
max(5, 2, 8, 1)                    # 8
first { $_ > 5 } @nums            # First element > 5
any   { $_ < 0 } @nums            # True if any negative
all   { $_ > 0 } @nums            # True if all positive
reduce { $a * $b } 1..5            # 120 (product)

# Schwartzian Transform — efficient sort by computed key
my @by_len = map  { $_->[0] }
             sort { $a->[1] <=> $b->[1] }
             map  { [$_, length($_)] }
             @words;

# Time
time()                             # Unix timestamp (integer)
scalar localtime()                 # Human-readable time string

# System
system("ls");                      # Run command; return exit code
my $output = `ls -la`;             # Backtick: capture output
exit(0);                           # Terminate with status

# @ARGV holds all command-line arguments
# perl myscript.pl file.txt --count 3
my $file  = $ARGV[0];
my $count = $ARGV[1];

# Getopt::Long — proper flag parsing
use Getopt::Long;
my ($verbose, $output, $count) = (0, "out.txt", 1);

GetOptions(
    "verbose|v"  => \$verbose,     # Boolean flag
    "output|o=s" => \$output,      # =s: string required
    "count|n=i"  => \$count,       # =i: integer required
) or die "Usage: $0 [--verbose] [--output FILE] [--count N]\n";

# Run as: perl script.pl --verbose --output results.txt -n 5

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

# 1. Create the main window
my $mw = MainWindow->new;
$mw->title("My App");
$mw->geometry("400x300");    # WxH in pixels (optional)

# 2. Create widgets
$mw->Label(-text => "Hello, Perl/Tk!")->pack;

# 3. Enter the event loop — never returns until window closes
MainLoop;

my $message = "Hello";
$mw->Label(-textvariable => \$message)->pack;

# Changing $message later automatically updates the label!
$message = "World";    # Label immediately shows "World"

my $btn = $mw->Button(-text => "Click Me");
$btn->pack;

# Change options after creation
$btn->configure(-text => "Updated", -foreground => "red");

# Read the current value of an option
my $current_text = $btn->cget(-text);

$parent->Button(
    -text             => "Submit",
    -font             => "Helvetica 13 bold",
    -foreground       => "#ffffff",
    -background       => "#007aff",
    -activebackground => "#0058cc",
    -relief           => "flat",     # flat raised sunken groove ridge
    -state            => "normal",   # normal active disabled
    -width            => 12,
    -padx             => 12,
    -pady             => 6,
    -command          => \&on_submit,
)->pack;

$widget->pack(
    -side   => "top",    # top (default) | bottom | left | right
    -fill   => "x",      # x | y | both | none  — fill available space
    -expand => 1,        # 1 = grow to fill extra space
    -anchor => "w",      # n ne e se s sw w nw center
    -padx   => 5,        # Horizontal outer padding
    -pady   => 3,        # Vertical outer padding
);

$widget->grid(
    -row        => 0,
    -column     => 1,
    -columnspan => 2,       # Span multiple columns
    -sticky     => "nsew",  # Stick to all edges (stretch)
    -padx       => 5,
    -pady       => 3,
);

# Make column 1 stretch when window resizes
$parent->gridColumnconfigure(1, -weight => 1);

$widget->place(-x => 100, -y => 50, -width => 120, -height => 30);
# or relative (0.0 to 1.0 of parent size):
$widget->place(-relx => 0.5, -rely => 0.5, -anchor => "center");

# bind() attaches a callback to an event
$widget->bind("<Button-1>",  \&on_left_click);   # Left mouse button
$widget->bind("<Button-3>",  \&on_right_click);  # Right click
$widget->bind("<Double-1>",  \&on_double_click); # Double-click
$widget->bind("<Return>",    \&on_enter_key);    # Enter key
$widget->bind("<Escape>",    sub { exit });
$widget->bind("<Motion>",    \&on_mouse_move);   # Mouse movement

# Accessing event coordinates
$canvas->bind("<Button-1>", sub {
    my $e = $canvas->XEvent;
    printf "Clicked at %d, %d\n", $e->x, $e->y;
});

# On macOS, Command key = Meta in Perl/Tk
$mw->bind("<Meta-s>",      \&save);      # Cmd+S
$mw->bind("<Meta-z>",      \&undo);      # Cmd+Z
$mw->bind("<Meta-q>",      sub { exit }); # Cmd+Q
$mw->bind("<Control-a>",   \&select_all);
$mw->bind("<Shift-Return>", \&submit);

# Run once after 2000ms
$mw->after(2000, sub { print "2 seconds passed\n" });

# Repeating timer — re-schedule inside the callback
sub tick {
    update_clock_display();
    $mw->after(1000, \&tick);    # Schedule next tick
}
tick();    # Start the clock

# Menubar
my $menu = $mw->Menu;
$mw->configure(-menu => $menu);

my $file = $menu->cascade(-label => "File", -tearoff => 0);
$file->command(-label => "Open…", -accelerator => "Cmd+O", -command => \&open_file);
$file->separator;
$file->command(-label => "Quit",  -accelerator => "Cmd+Q", -command => sub { exit });

my $edit = $menu->cascade(-label => "Edit", -tearoff => 0);
$edit->checkbutton(-label => "Word Wrap", -variable => \$wrap);
$edit->radiobutton(-label => "Light",     -variable => \$theme, -value => "light");

# Built-in dialogs
my $ans = $mw->messageBox(
    -title   => "Confirm",
    -message => "Are you sure?",
    -type    => "YesNo",         # YesNo  OKCancel  AbortRetryIgnore
    -icon    => "question",      # question warning error info
);

# File chooser dialogs
my $file = $mw->getOpenFile(-title => "Open", -filetypes => [
    ["Text Files", ".txt"], ["All Files", "*"]
]);
my $file = $mw->getSaveFile(-title => "Save As", -initialfile => "untitled.txt");

# Color chooser
my $color = $mw->chooseColor(-title => "Pick Color", -initialcolor => "#ff0000");

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

# Draw shapes — each returns an item ID
my $line = $canvas->createLine(10, 10, 200, 100,
    -fill => "blue", -width => 2, -arrow => "last");

my $rect = $canvas->createRectangle(50, 50, 200, 150,
    -fill => "lightblue", -outline => "navy", -width => 2);

my $oval = $canvas->createOval(250, 50, 400, 200,
    -fill => "yellow", -outline => "orange");

my $txt  = $canvas->createText(300, 250,
    -text => "Hello Canvas!", -font => "Helvetica 16 bold", -fill => "darkgreen");

# Modify items
$canvas->move($rect, 10, 5);                          # Move by delta
$canvas->itemconfigure($oval, -fill => "red");         # Change color
$canvas->delete($line);                                # Remove one item
$canvas->delete("all");                                # Clear everything

# Canvas tags — group items for bulk operations
$canvas->createOval(... -tags => ["ball", "moving"]);
$canvas->move("moving", 5, 0);                         # Move all "moving"

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

# ── 1. State variables — ALL data here, not inside callbacks ──
my $current_file = undef;
my $modified     = 0;
my $status_msg   = "Ready";

# ── 2. Main window ────────────────────────────────────────────
my $mw = MainWindow->new;
$mw->title("My App");
$mw->geometry("800x600");
$mw->protocol("WM_DELETE_WINDOW", \&on_quit);   # Intercept close button

# ── 3. Build UI ───────────────────────────────────────────────
build_menu($mw);
build_toolbar($mw);
build_body($mw);
build_status($mw);

# ── 4. Keyboard shortcuts ─────────────────────────────────────
$mw->bind("<Meta-s>", \&cmd_save);
$mw->bind("<Meta-q>", \&on_quit);

# ── 5. Start event loop ───────────────────────────────────────
MainLoop;

# ── 6. All subroutines below ──────────────────────────────────
sub on_quit {
    if ($modified) {
        my $ans = $mw->messageBox(-type => "YesNoCancel",
            -message => "Save before quitting?");
        return if $ans eq "Cancel";
        cmd_save() if $ans eq "Yes";
    }
    exit;
}

# On macOS, the Command (⌘) key maps to Meta in Perl/Tk
$mw->bind("<Meta-n>", \&new_file);   # ⌘N
$mw->bind("<Meta-o>", \&open_file);  # ⌘O
$mw->bind("<Meta-s>", \&save_file);  # ⌘S
$mw->bind("<Meta-w>", sub { $mw->destroy }); # ⌘W
$mw->bind("<Meta-q>", sub { exit });  # ⌘Q

# These fonts look native on macOS:
-font => "Helvetica 13"          # Clean system-like sans-serif
-font => "Helvetica 13 bold"
-font => "Courier 12"             # Monospace
-font => "Monaco 12"              # macOS native monospace

-background => "#f5f5f5"    # Light gray (like macOS panels)
-foreground => "#1a1a1a"    # Near-black text
-background => "#007aff"    # macOS blue
-background => "#34c759"    # macOS green
-background => "#ff3b30"    # macOS red

# Install Platypus from: https://sveinbjorn.org/platypus
# Platypus wraps any Perl script into a native macOS .app bundle
# with a Dock icon, menu bar name, and all standard macOS behaviors.