The Perl Language
in Practice

use strict;
use warnings;

my $name    = "Alice";
my $age     = 30;
my $pi      = 3.14159;
my $nothing = undef;

# Double-quotes interpolate; single-quotes are literal
my $city = "San Francisco";
print "Welcome to $city!\n";         # → Welcome to San Francisco!
print 'No interpolation: $city\n', "\n";  # literal

# Checking defined vs. undef
print defined($nothing) ? "defined" : "undef";    # → undef

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

# String functions
my $sample = "  Perl Programming  ";
print length($sample);        # 20
print uc($sample);            # "  PERL PROGRAMMING  "
print ucfirst(lc("hELLO"));   # "Hello"
print substr("Submarine", 3, 4);   # "marin"
print index("Submarine", "arin");  # 4

# chomp removes the trailing newline
my $s = "Hello\n";
chomp $s;    # $s is now "Hello" (no newline)

# sprintf — formatted strings
printf "%-22s %s\n", "Zero-padded:",   sprintf("%08d", 42);    # 00000042
printf "%-22s %s\n", "Float:",         sprintf("%.4f", 3.14);  # 3.1400
printf "%-22s %s\n", "Left-aligned:",  sprintf("%-10s|", "hi"); # "hi        |"

# Here-doc — multi-line string
my $poem = <<END_POEM;
Roses are red,
Violets are blue,
Perl is awesome.
END_POEM

use POSIX qw(floor ceil);

# Literal forms
my $hex = 0xFF;        # 255
my $oct = 0755;        # 493
my $bin = 0b1010;      # 10
my $big = 1_000_000;   # underscores for readability

# Arithmetic
printf "17 + 5  = %d\n",   17 + 5;
printf "17 % 5  = %d\n",   17 % 5;   # modulus
printf "2 ** 10 = %d\n",   2 ** 10;  # exponent → 1024

# Math functions
print abs(-42),    "\n";   # 42
print int(3.9),    "\n";   # 3  (truncate, not round)
print sqrt(144),   "\n";   # 12
print floor(3.7),  "\n";   # 3
print ceil(3.2),   "\n";   # 4

# Numeric sort (must use $a <=> $b)
my @nums    = (5, 2, 9, 1, 7, 3);
my @sorted  = sort { $a <=> $b } @nums;
print join(", ", @sorted);    # 1, 2, 3, 5, 7, 9

# Spaceship operator <=> returns -1, 0, or 1
print 10 <=> 20;    # -1

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

my @colors = ("red", "green", "blue");
my @range  = (1..10);                   # range operator

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

# Modification
push    @colors, "yellow";   # Add to end
my $out = pop @colors;       # Remove from end
unshift @colors, "white";    # Add to front
my $fst = shift @colors;     # Remove from front
splice(@colors, 1, 1, "lime"); # Replace element at index 1

# Functional operations — grep, map, sort
my @evens   = grep { $_ % 2 == 0 } @range;
my @doubled = map  { $_ * 2 }      @range;
my @words   = qw(banana apple cherry date elderberry);
my @bylen   = sort { length($a) <=> length($b) || $a cmp $b } @words;

print "sum=", sum(@range), "  min=", min(@range), "  max=", max(@range), "\n";

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

# wantarray — context detection
sub ctx { return wantarray ? (1, 2, 3) : "scalar_result" }
my @as_list   = ctx();     # (1, 2, 3)
my $as_scalar = ctx();     # "scalar_result"

my %person = (
    name  => "Bob",           # fat comma auto-quotes the left side
    age   => 25,
    city  => "Austin",
    email => 'bob@example.com',
);

# Access, add, delete
my $name  = $person{name};
$person{phone} = "555-1234";
delete $person{phone};

# Test keys
print exists  $person{name} ? "exists"  : "missing";
print defined $person{age}  ? "defined" : "undef";

# Iterate — always sort keys for reproducible output
foreach my $key (sort keys %person) {
    printf "  %-8s => %s\n", $key, $person{$key};
}

# Hash slice — get or set multiple keys at once
my @info            = @person{qw(name city)};
@person{qw(x y)}    = (10, 20);

# Common patterns
my @data = qw(pear apple banana cherry apple pear pear);

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

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

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

unless ($score < 60) { print "Passing!\n" }  # unless = opposite of if

# Postfix (statement modifier) — readable one-liners
print "Positive\n" if $score > 0;
print "Not zero\n" unless $score == 0;

# Ternary and defined-or
my $result = ($score >= 60) ? "Pass" : "Fail";
my $val    = undef // "default";   # "default"

# Loops
my $i = 1;
while ($i <= 5) { print "$i "; $i++ }       # while
for (my $n=0; $n<5; $n++) { print "$n " }   # C-style for
foreach my $c (qw(red green blue)) { print "$c " }  # foreach
print "$_ " for 1..5;                         # postfix for

# Loop control
for my $n (1..20) {
    next if $n % 2 == 0;    # skip even numbers
    last if $n > 9;          # stop after 9
    print "$n ";             # → 1 3 5 7 9
}

# Loop labels — control outer loop from inner loop
OUTER: for my $row (1..3) {
    for my $col (1..3) {
        next OUTER if $col == 2;
        print "($row,$col) ";
    }
}
# → (1,1) (2,1) (3,1)

# map and grep — functional loops
my @squares = map  { $_ ** 2 } 1..8;
my @odds    = grep { $_ % 2  } 1..10;

my $text = "The quick brown fox jumps over the lazy dog.";

# Basic match / negated match
print "has fox\n" if $text =~ /fox/;
print "no cat\n"  if $text !~ /cat/;

# Case-insensitive with /i modifier
print "found\n" if $text =~ /QUICK/i;

# Substitution — s/old/new/flags
(my $copy = $text) =~ s/fox/cat/;        # Replace first
(my $copy2= $text) =~ s/\b\w{4}\b/XXXX/g; # Replace all 4-letter words

# Capturing groups — $1, $2, $3 ...
my $date = "Dates: 2024-05-04 and 2024-12-25.";
if ($date =~ /(\d{4})-(\d{2})-(\d{2})/) {
    print "Year=$1  Month=$2  Day=$3\n";
}

# Find ALL matches with /g in list context
my @all_dates = ($date =~ /(\d{4}-\d{2}-\d{2})/g);
print join(", ", @all_dates);    # 2024-05-04, 2024-12-25

# Named captures — $+{name}
my $log = "ERROR 404: Page not found";
if ($log =~ /(?<level>\w+)\s+(?<code>\d+):\s+(?<msg>.+)/) {
    printf "Level=%-8s Code=%-5s Msg=%s\n",
           $+{level}, $+{code}, $+{msg};
}

# tr — transliteration
(my $upper = "Hello World") =~ tr/a-z/A-Z/;
my $count = ("Hello" =~ tr/aeiouAEIOU//);   # Count vowels → 2

# Split on regex
my @fields = split(/\s*,\s*/, "one,  two ,three");

# Extended /x mode — add comments for readability
my $valid = 'user@example.com' =~ /
    ^           # Start
    [\w.+\-]+   # Local part
    @           # At-sign
    [\w\-]+     # Domain
    (\.\w+)+    # Extensions
    $           # End
/x;

# Arguments arrive in @_ — always unpack with my
sub greet {
    my ($name, $greeting) = @_;
    $greeting //= "Hello";          # default value
    return "$greeting, $name!";
}

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

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

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

# Closure — captures $factor from the enclosing scope
sub make_multiplier {
    my ($factor) = @_;
    return sub { $_[0] * $factor };
}
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] },
    mul => sub { $_[0] * $_[1] },
    div => sub { $_[1] ? $_[0]/$_[1] : "undef" },
);
print $ops{add}->(10, 3);   # 13

# Recursive subroutine
sub factorial { $_[0] <= 1 ? 1 : $_[0] * factorial($_[0]-1) }
printf "%d! = %d\n", $_, factorial($_) for 0..8;

use List::Util qw(sum);
use Data::Dumper;

# Anonymous array ref [ ] and hash ref { }
my $aref = [10, 20, 30];
my $href = { x => 1, y => 2 };

print $aref->[1];    # 20
print $href->{x};    # 1

# Array of hashes — most common "record" structure
my @team = (
    { name => "Alice", role => "dev",  level => 5 },
    { name => "Bob",   role => "ops",  level => 3 },
    { name => "Carol", role => "dev",  level => 7 },
);

# Sort, filter, transform via arrow notation
my @by_level = sort { $b->{level} <=> $a->{level} } @team;
my @devs     = grep { $_->{role} eq "dev" } @team;
my $total    = sum(map { $_->{level} } @team);

printf "  %-8s %-8s Lv.%d\n", $_->{name}, $_->{role}, $_->{level}
    for @by_level;

# Hash of arrays — group-by pattern
my %by_role;
push @{ $by_role{$_->{role}} }, $_->{name} for @team;
for my $role (sort keys %by_role) {
    printf "  %-8s: %s\n", $role, join(", ", @{ $by_role{$role} });
}

# Deeply nested structure
my $company = {
    depts => {
        eng => { head => "Alice", staff => [qw(Bob Carol)] },
    },
};
push @{ $company->{depts}{eng}{staff} }, "Dave";
print join(", ", @{ $company->{depts}{eng}{staff} });
# → Bob, Carol, Dave

# Data::Dumper for debugging
local $Data::Dumper::Indent   = 1;
local $Data::Dumper::Sortkeys = 1;
print Dumper({ nums => [1..3], meta => { env => "dev" } });

# Three-argument open — always use this form
open(my $wfh, ">", "/tmp/test.txt")  or die "Cannot write: $!";
print $wfh "Hello, file!\n";
printf $wfh "Squared: %d\n", 7**2;
close($wfh);

# Read line by line — memory efficient for large files
open(my $rfh, "<", "/tmp/test.txt") or die "Cannot read: $!";
while (my $line = <$rfh>) {
    chomp $line;       # Remove trailing \n
    print "[$line]\n";
}
close($rfh);

# Slurp entire file into a string at once
open(my $sfh, "<", "/tmp/test.txt") or die "$!";
my $content = do { local $/; <$sfh> };
close($sfh);
printf "File: %d chars\n", length($content);

# File test operators
printf "-e exists:   %s\n", (-e "/tmp/test.txt" ? "yes" : "no");
printf "-f regular:  %s\n", (-f "/tmp/test.txt" ? "yes" : "no");
printf "-s size:     %d bytes\n", -s "/tmp/test.txt";

# Append mode
open(my $app, ">>", "/tmp/test.txt") or die "$!";
print $app "Appended line\n";
close($app);

unlink "/tmp/test.txt";    # Delete the file

# eval — catch exceptions (Perl's try/catch)
eval { die "Something failed!\n" };
print "Caught: $@" if $@;

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

# ── Object-Oriented Perl ──────────────────────────────────
{ package Animal;
  sub new {
      my ($class, %a) = @_;
      bless { name => $a{name}//"?", sound => $a{sound}//"..." }, $class;
  }
  sub name  { $_[0]->{name} }
  sub speak { printf "%s says: %s\n", $_[0]->{name}, $_[0]->{sound} }
}
{ package Dog;
  our @ISA = ('Animal');
  sub new { my($cl,%a)=@_; $a{sound}="Woof"; $cl->Animal::new(%a) }
  sub fetch { print "$_[0]->{name} fetches!\n" }
}
{ package Cat;
  our @ISA = ('Animal');
  sub new { my($cl,%a)=@_; $a{sound}="Meow"; $cl->Animal::new(%a) }
  sub purr { print "$_[0]->{name} purrs.\n" }
}
package main;

my $dog = Dog->new(name => "Rex");
my $cat = Cat->new(name => "Whiskers");

$dog->speak;   # Rex says: Woof
$cat->speak;   # Whiskers says: Meow
$dog->fetch;   # Rex fetches!
$cat->purr;    # Whiskers purrs.

# ref() tells you the class; isa() checks the hierarchy
print ref($dog);                # Dog
print $dog->isa("Animal");     # 1 (true — inherited!)
print $dog->isa("Cat");        # "" (false)

my @contacts = (
    { first => "Alice",  last => "Anderson", city => "Austin",  phone => "555-0101" },
    { first => "Bob",    last => "Brown",    city => "Boston",  phone => "555-0202" },
    { first => "Carol",  last => "Clark",    city => "Austin",  phone => "555-0303" },
    { first => "Dave",   last => "Davis",    city => "Dallas",  phone => "555-0404" },
);

sub full_name { "$_[0]->{first} $_[0]->{last}" }

# Print all, sorted by last name
printf "  %-20s  %-12s  %s\n", full_name($_), $_->{phone}, $_->{city}
    for sort { $a->{last} cmp $b->{last} } @contacts;

# Filter — only Austin contacts
my @austin = grep { $_->{city} eq "Austin" } @contacts;
print full_name($_), "\n" for @austin;

# Group by city
my %by_city;
push @{ $by_city{$_->{city}} }, full_name($_) for @contacts;
printf "  %-10s: %s\n", $_, join(", ", sort @{ $by_city{$_} })
    for sort keys %by_city;

# Search by last name
my ($found) = grep { $_->{last} =~ /^Davis$/i } @contacts;
printf "Found: %s (%s)\n", full_name($found), $found->{phone} if $found;

# CSV export
print "First,Last,Phone,City\n";
printf "%s,%s,%s,%s\n", @{$_}{qw(first last phone city)}
    for sort { $a->{last} cmp $b->{last} } @contacts;