Understanding
Intermediate
Perl

# Each value is an anonymous sub (coderef) — note the sub { } syntax
my %calc = (
    add  => sub { $_[0] + $_[1] },   # $_[0], $_[1] are args to THIS anon sub
    div  => sub {
        die "Division by zero\n" if $_[1] == 0;
        $_[0] / $_[1];
    },
);

# Dispatch: $calc{op} retrieves the coderef, ->() calls it
sub calculate {
    my ($op, $a, $b) = @_;
    die "Unknown op: $op\n" unless exists $calc{$op};
    return $calc{$op}->($a, $b);  # ->() dereferences and calls
}

# Add a new operation dynamically — no rewriting needed
$calc{mod} = sub { $_[0] % $_[1] };

use Carp qw(croak);

# croak: like die, but blames the CALLER, not this function
sub divide {
    my ($a, $b) = @_;
    croak "Cannot divide by zero" if $b == 0;
    return $a / $b;
}

# eval { } is the try-block — catches any die/croak inside
eval { divide(10, 0) };

# CRITICAL: copy $@ immediately — it can be cleared by object DESTROY methods
if (my $err = $@) {
    print "Caught: $err\n";
}

# Exception objects: die with a blessed reference instead of a string
package MyException;
sub new {
    my ($class, %args) = @_;
    return bless { message => $args{message}, code => $args{code} }, $class;
}

package main;
eval {
    die MyException->new(message => "Not found", code => 404);
};
if (my $e = $@) {
    # ref() tells you if $@ is an object vs a plain string
    if (ref $e && $e->isa('MyException')) {
        printf "Object error [%d]: %s\n", $e->{code}, $e->{message};
    }
}

# make_counter RETURNS a closure — not a value, but a function
sub make_counter {
    my ($start, $step) = @_;
    my $count = $start;   # <-- THIS is captured by the closures below

    return {
        # Each anonymous sub closes over $count and $start/$step
        next  => sub { $count += $step },   # modifies $count
        reset => sub { $count  = $start },  # resets $count to original
        value => sub { $count           },  # reads $count
    };
}

# c1 and c2 are INDEPENDENT — they each have their own $count
my $c1 = make_counter(0,   1);
my $c2 = make_counter(100, -10);

# Memoization: a closure that remembers previous results
sub memoize {
    my ($fn) = @_;
    my %cache;               # private cache captured by this closure
    return sub {
        my $key = join(',', @_);
        return $cache{$key} if exists $cache{$key};
        return $cache{$key} = $fn->(@_);
    };
}

# Read and parse; @fields holds column names from header
my $header = <$fh>;
chomp $header;
my @fields = split /,/, $header;  # ("name","dept","salary")

my %by_dept;

while (my $line = <$fh>) {
    chomp $line;
    next unless $line =~ /\S/;       # skip blank lines

    # Hash slice: @rec{@fields} = ... fills multiple hash keys at once
    # @fields = ("name","dept","salary")
    # split gives ("Alice","Eng","95000")
    # Result: $rec{name}="Alice", $rec{dept}="Eng", $rec{salary}="95000"
    my %rec;
    @rec{@fields} = split /,/, $line;

    # push a REFERENCE to the record into the dept's array
    push @{ $by_dept{ $rec{dept} } }, \%rec;
}

# Accessing grouped data: $by_dept{Eng} is an arrayref of hashrefs
for my $dept (sort keys %by_dept) {
    my @salaries = map { $_->{salary} } @{ $by_dept{$dept} };
}

use List::Util qw(sum sum0 product min max first any all none reduce uniq pairs);

my @nums = (3, 1, 4, 1, 5, 9, 2, 6);

# sum() returns undef on empty list — sum0() returns 0 (safer)
sum(@nums);      # 31
sum0();         # 0 (not undef)
product(@nums); # 6480

# first — stops at the FIRST match (unlike grep which scans all)
my $big = first { $_ > 5 } @nums;    # 9 (first element > 5)

# any/all/none — boolean, also short-circuit for performance
any  { $_ % 2 == 0 } @nums;  # true  (stops at first even)
all  { $_ > 0        } @nums;  # true  (stops if any fail)
none { $_ < 0        } @nums;  # true  (stops if any negative found)

# reduce — folds list with $a=accumulator, $b=current element
# This computes GCD of a list using Euclidean algorithm
my $gcd = reduce {
    my ($x, $y) = ($a, $b);        # copy first; $a and $b are aliases
    ($x, $y) = ($y, $x % $y) while $y;
    $x;
} 48, 36, 24;

# uniq removes duplicates (keeps first occurrence)
# Sort FIRST if you want all duplicates removed, not just consecutive ones
my @unique = uniq sort {$a<=>$b} @nums;  # 1 2 3 4 5 6 9

# Goal: sort filenames in natural order (report1, report2, report10)
# Not alphabetical (report1, report10, report2)

my @nat_sorted =
    map  { $_->[0] }            # Phase 3: unwrap — discard the cached keys
    sort {
        $a->[1] cmp  $b->[1]  # Phase 2: compare prefix alphabetically
        ||
        $a->[2] <=>  $b->[2]  #         then suffix numerically
    }
    map  {                       # Phase 1: decorate with computed keys
        my ($prefix, $num) = $_ =~ /^([a-z]+)(\d*)/i;
        [$_, $prefix, $num || 0]  # [$original, $alpha_key, $num_key]
    }
    @files;                      # input — read bottom-to-top

# The || in sort: if prefixes are equal (cmp returns 0), use numeric sort
# 0 is false in Perl, so || falls through to the second comparison

# Format anatomy: %[flags][width][.precision]type
#
#  flags:     - (left-align)  + (force sign)  0 (zero-pad)  space
#  width:     minimum field width (pads with spaces by default)
#  .precision: max chars for strings, decimal places for floats
#  type:      d(int) f(float) s(string) e(sci) g(smart) x(hex) b(bin)

printf "%d\n",     42;       # "42"      — basic integer
printf "%8d\n",    42;       # "      42" — right-aligned in 8-wide field
printf "%-8d|\n",   42;       # "42      |" — left-aligned (- flag)
printf "%08d\n",   42;       # "00000042"  — zero-padded (0 flag)
printf "%+d\n",    42;       # "+42"       — forced sign (+ flag)

printf "%.2f\n",   3.14159;  # "3.14"     — 2 decimal places
printf "%10.3f\n", 3.14159;  # "     3.142" — width 10, 3 decimals
printf "%g\n",    0.00001;  # "1e-05"    — %g picks shorter of %f or %e

# Multiple values in one printf — positional
printf "%-12s %6d %9.2f %12.2f\n",
    "Widget A", 1024, 9.99, 1024 * 9.99;

# sprintf: build the string without printing
my $label = sprintf "[%05d] %-20s", 42, "Alice";

# has 'name' declares an attribute with full config
has 'name' => (
    is       => 'ro',     # read-only: getter generated, no setter
    isa      => 'Str',    # type constraint: dies if not a string
    required => 1,         # must be passed to new()
);

has 'sound' => (
    is      => 'rw',      # read-write: getter AND setter generated
    isa     => 'Str',
    default => '...',     # default value if not given to new()
);

# Role: a reusable bundle of behaviour (like an interface + implementation)
package Printable;
use Moose::Role;
requires 'to_string';     # any class using this role MUST implement to_string
sub print_self { print $_[0]->to_string() . "\n" }

# Subclass Dog extends Animal, overrides the 'sound' default
package Dog;
use Moose;
extends 'Animal';
has '+sound' => ( default => 'Woof!' );  # + prefix modifies parent's attr

# before modifier: runs BEFORE speak() without replacing it
before 'speak' => sub {
    print "[Dog wags tail]\n";    # runs, then original speak() runs
};

use JSON::PP;

# Chain config methods: utf8 + pretty + canonical (sorted keys)
my $json = JSON::PP->new->utf8->pretty->canonical;

# JSON true/false/null must use JSON::PP constants — not 1/0/undef!
my %config = (
    debug   => JSON::PP::true,   # encodes as JSON true (not "true" or 1)
    timeout => JSON::PP::null,   # encodes as JSON null (not undef/"")
    ports   => [8080, 8443],      # arrayref -> JSON array
    db      => { host => "localhost" },  # hashref -> JSON object
);

# encode() takes a REFERENCE (not a plain hash)
my $str = $json->encode(\%config);

# decode() returns a reference — dereference to use
my $data = $json->decode($str);
print $data->{db}->{host};         # "localhost"

# Always wrap decode() in eval — invalid JSON throws an exception
my $parsed = eval { $json->decode('{ bad }') };
warn "JSON error: $@" if $@;

use Getopt::Long;

# Declare variables with defaults BEFORE GetOptions
my $input   = '-';    # '-' means stdin by convention
my $count   = 10;
my $verbose = 0;
my @tags;            # will accumulate multiple --tag values

GetOptions(
    'input=s'   => \$input,   # =s  requires a string argument
    'count=i'   => \$count,   # =i  requires an integer
    'tag=s'     => \@tags,    # array ref: each --tag adds to @tags
    'verbose|v' => \$verbose, # boolean flag; |v adds -v short alias
    'help|h'    => sub { print "Usage...\n"; exit },  # inline handler
) or die "Usage error. Try --help\n";

# After GetOptions, @ARGV holds any remaining non-option arguments
# e.g. "script.pl --count 5 file1.txt file2.txt" leaves @ARGV = ("file1.txt","file2.txt")

# Type specifiers:  =s string  =i integer  =f float  =o extended integer
# Optional value:   :s  :i  (value is optional; undef if not given)
# No value (flag):  just the name, no = sign

# --- Lookahead: match X only when followed by Y ---
# (?=Y) asserts Y is ahead WITHOUT consuming it
my $text = "100USD 200EUR 75USD";
my @usd = ($text =~ /(\d+)(?=USD)/g);  # captures 100, 75 (not 200)

# --- Lookbehind: match X only when preceded by Y ---
# (?<=Y) asserts Y is behind WITHOUT consuming it
my @codes = ($text =~ /(?<=\d)([A-Z]{3})/g);  # USD, EUR, USD

# --- Negative forms ---
# (?!Y)  — NOT followed by Y
# (?<!Y) — NOT preceded by Y

# --- Backreference: \1 refers to what group 1 captured ---
# Remove duplicate words: \b(\w+)\s+\1\b  — word, space(s), SAME word
my $s = "the the quick fox fox";
$s =~ s/\b(\w+)\s+\1\b/$1/gi;     # "the quick fox" — /i for case-insensitive

# --- tr/// (transliterate) — character-by-character mapping ---
# tr/SEARCH/REPLACE/ — each char in SEARCH maps to same-position char in REPLACE
my $str = "Hello World";
$str =~ tr/a-z/A-Z/;       # uppercase (like uc() but in-place)
my $digits = ($str =~ tr/0-9//);  # tr returns COUNT of chars matched

# --- qr// — compiled, reusable regex value ---
my $email_re = qr/^[\w.+-]+\@[\w-]+\.\w{2,}$/;  # compiled once
my @valid = grep { $_ =~ $email_re } @candidates;  # reused each iteration

use DBI;

# Connect: DSN (Data Source Name) format: "dbi:Driver:params"
my $dbh = DBI->connect(
    'dbi:SQLite:dbname=:memory:',  # DSN — change for MySQL/Postgres
    '', '',                           # username, password
    { RaiseError => 1, AutoCommit => 1 }  # RaiseError: die on errors
) or die DBI->errstr;

# do() for one-shot statements (DDL, simple DML)
$dbh->do('CREATE TABLE t (id INTEGER, name TEXT)');

# prepare() compiles the SQL; ? are placeholders — NEVER interpolate user data
my $ins = $dbh->prepare('INSERT INTO t VALUES (?, ?)');

# Transaction: wrap multiple inserts — all succeed or all roll back
eval {
    $dbh->{AutoCommit} = 0;            # begin transaction
    $ins->execute(1, 'Alice');
    $ins->execute(2, 'Bob');
    $dbh->commit;                       # commit all at once
};
if ($@) { $dbh->rollback; die $@ }
$dbh->{AutoCommit} = 1;

# Fetch options:
# fetchrow_arrayref  — fastest, one row as array ref
# fetchrow_hashref   — row as hash ref (column_name => value)
# fetchall_arrayref  — all rows as array of arrayrefs
my $sth = $dbh->prepare('SELECT * FROM t WHERE id > ?');
$sth->execute(0);
while (my $row = $sth->fetchrow_hashref) {
    print "$row->{id}: $row->{name}\n";
}

# selectrow_array — convenience for single-row results
my ($count) = $dbh->selectrow_array('SELECT COUNT(*) FROM t');

$dbh->disconnect;