Perl チートシート

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

print "Hello, World!\n";

# variables: scalar ($), array (@), hash (%)
my $name = "Alice";
my @nums = (1, 2, 3);
my %ages = (Alice => 30, Bob => 25);

print "Name: $name\n";

#!/usr/bin/perl
# This is a single-line comment

print "Hello\n";  # inline comment

=pod
This is a multi-line
comment using POD (Plain Old Documentation)
=cut

print "After POD\n";

my $str = "Hello";
my $num = 42;
my $float = 3.14;
my $bool = 1;  # true (0, "", "0", undef are false)

# String repetition
my $line = "-" x 20;

# String concatenation
my $greeting = "Hello, " . $str;

print "$greeting\n";  # Hello, Hello

my $name = "Alice";
my $age = 30;

print "Name: $name\n";   # interpolates
print 'Name: $name\n';   # literal (no interpolation)

# Disambiguate variable name with braces
my $fruit = "apple";
print "I have many ${fruit}s.\n";  # I have many apples.

# Array interpolation (joins with $")
my @arr = (1, 2, 3);
print "Array: @arr\n";  # Array: 1 2 3

use strict;
use warnings;

# Without strict, this would create a global:
# $foo = 42;   # ERROR under strict
my $foo = 42;  # OK with my

# Warnings catch common mistakes
my $undef_var;
# print $undef_var;  # warns: uninitialized value

# Modern bundle (v5.36+ enables strict, warnings, features)
use v5.36;

# Disable specific warnings locally
no warnings 'uninitialized';

use v5.10;
use feature 'say';

say "Hello!";  # adds newline automatically
say "No need for \n";

# Equivalent to:
print "Hello!\n";

# Signatures (v5.20+, not default)
use feature 'signatures';
no warnings 'experimental::signatures';
sub greet ($name) {
    say "Hi, $name";
}

my $sum  = 5 + 3;        # 8
my $diff = 10 - 4;       # 6
my $prod = 6 * 7;        # 42
my $div  = 10 / 3;       # 3.3333...
my $int  = int(10 / 3);  # 3
my $mod  = 10 % 3;       # 1
my $pow  = 2 ** 10;      # 1024

# Augmented assignment
my $x = 5;
$x += 3;   # $x = 8
$x **= 2;  # $x = 64
$x++;      # $x = 65
$x--;      # $x = 64

my $a = "Hello";
my $b = "World";

# Concatenation
my $combined = $a . ", " . $b;  # Hello, World

# Repetition
my $line = "=" x 30;

# Augmented concatenation
my $str = "abc";
$str .= "def";  # abcdef

# Numeric vs string comparison
print "match" if "abc" eq "abc";  # string equal
print "match" if 123 == 123;      # numeric equal

my $x;               # undef
print "undef\n" if !defined $x;

$x = undef;          # explicitly undef
undef $x;            # another way

# Defined-or operator
my $val = $x // "default";

# Warning if used as string:
# print $x;  # Use of uninitialized value

if (defined $val) {
    print "Defined: $val\n";
}

my $name = "Alice";

# q() = single quote (no interpolation)
my $s1 = q(Hello $name);    # Hello $name

# qq() = double quote (interpolation)
my $s2 = qq(Hello $name);   # Hello Alice

# qw() = quoted words (produces a list)
my @words = qw(apple banana cherry);
# equivalent to ("apple", "banana", "cherry")

# Custom delimiters
my $s3 = q{don't worry};
my $s4 = q!bang!;

my $name = "Alice";

# Single-quote style (no interpolation)
my $text = <<'END';
Hello $name,
This is literal.
END

# Double-quote style (interpolation)
my $msg = <<"EOF";
Hello $name,
Interpolated here.
EOF

print $msg;

# Indented heredoc (v5.26+)
my $code = <<~EOT;
    line 1
    line 2
    EOT

# False values: undef, 0, "", "0"
# Everything else is true

print "true\n" if 1;        # true
print "true\n" if "hello";  # true
print "true\n" if "0";      # NOT printed (false!)
print "true\n" if "";       # NOT printed (false)
print "true\n" if [];       # true (reference is true)

# Logical operators
my $x = 0 || "default";   # default (|| tests truthiness)
my $y = 0 // "default";   # default (// tests definedness)
my $z = "a" && "b";       # b (returns last evaluated)

my @nums  = (1, 2, 3, 4, 5);
my @strs  = qw(a b c);
my @mixed = (1, "two", 3.14);

# Access by index (0-based)
print $nums[0];    # 1
print $nums[-1];   # 5 (last element)

# Modify an element
$nums[0] = 100;

# Range operator
my @range = (1 .. 10);  # 1 to 10

# Length in scalar context
my $count = scalar @nums;  # 5
my $count2 = @nums;        # 5

my @stack = (1, 2, 3);

# push/pop operate on the END
push @stack, 4, 5;        # (1, 2, 3, 4, 5)
my $last = pop @stack;    # 5

# unshift/shift operate on the START
unshift @stack, 0;        # (0, 1, 2, 3, 4)
my $first = shift @stack; # 0

# @stack is now (1, 2, 3, 4)
print "@stack\n";

# splice is the general-purpose tool
splice(@stack, 1, 0, 'x');  # insert at index 1

my @nums = (10, 20, 30, 40, 50);

# Array slice (returns a list)
my @slice = @nums[1, 3];      # (20, 40)
my @range = @nums[0 .. 2];    # (10, 20, 30)

# Modify multiple elements via slice
@nums[1, 3] = (200, 400);

# Last index
my $last_idx = $#nums;  # 4

# Negative indices count from the end
print $nums[-1];  # 50
print $nums[-2];  # 400

my @arr = (1, 2, 3, 4, 5);

# splice ARRAY, OFFSET, LENGTH, LIST
my @removed = splice(@arr, 1, 2);  # removes (2, 3)
# @arr is now (1, 4, 5)

# Insert without removing (LENGTH = 0)
splice(@arr, 1, 0, 'a', 'b');  # (1, 'a', 'b', 4, 5)

# Replace elements
splice(@arr, 0, 2, 'x');  # replace first 2 with 'x'

# Remove everything from offset to end
my @rest = splice(@arr, 2);

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

# Default sort is lexicographic (string)
my @s1 = sort @nums;

# Numeric ascending
my @s2 = sort { $a <=> $b } @nums;

# Numeric descending
my @desc = sort { $b <=> $a } @nums;

# String sort
my @words = qw(banana apple Cherry);
my @alpha = sort { lc($a) cmp lc($b) } @words;

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

my @arr = (1, 2, 3, 4, 5);

# Scalar context returns length
my $len = @arr;        # 5
print "Length: $len\n";

# String context joins with $"
print "Array: @arr\n";  # 1 2 3 4 5

# Change separator
local $" = ", ";
print "@arr\n";        # 1, 2, 3, 4, 5

# Last index
print "Last index: $#arr\n";  # 4

# Force scalar context
print scalar(@arr);    # 5

my %ages = (Alice => 30, Bob => 25, Carol => 35);

# Fat comma => auto-quotes the left side
my %h2 = (name => 'Alice', age => 30);

# Same as list of pairs:
my %h3 = ('name', 'Alice', 'age', 30);

# Access / modify a value
print $ages{Alice};   # 30
$ages{Dave} = 40;     # add
$ages{Alice} = 31;    # modify

# Delete a key
delete $ages{Bob};

my %h = (a => 1, b => 2, c => 3);

# Iterate keys
for my $k (keys %h) {
    print "$k => $h{$k}\n";
}

# Get all values
my @vals = values %h;

# each() returns key/value pairs iteratively
while (my ($k, $v) = each %h) {
    print "$k = $v\n";
}

# Sorted keys
for my $k (sort keys %h) { ... }

my %h = (name => 'Alice', age => 30);

# exists checks if a key is present
if (exists $h{name}) {
    print "Name exists\n";
}

# defined checks if the value is defined
if (defined $h{age}) { ... }

# delete removes a key, returns its value
my $removed = delete $h{age};

# Delete multiple keys (slice)
delete @h{qw(name age)};

# Empty a hash
%h = ();

my %h = (a => 1, b => 2, c => 3);

# Hash slice (returns list of values)
my @vals = @h{qw(a b)};   # (1, 2)

# Modify slice
@h{qw(a b)} = (10, 20);

# Key/value slice (v5.20+)
my @pairs = %h{qw(a b)};  # (a, 10, b, 20)

# Index/value slice
my @iv = %h{qw(a b)};

# Check multiple keys
my @present = grep { exists $h{$_} } qw(a x b);

my %people = (
    alice => { age => 30, city => 'NYC' },
    bob   => { age => 25, city => 'LA' },
);

# Access nested values
print $people{alice}{age};   # 30
print $people{bob}{city};    # LA

# Add new nested entry
$people{carol}{age}  = 35;
$people{carol}{city} = 'SF';

# Auto-vivification creates intermediate refs
$people{dave}{hobbies}[0] = 'reading';
# %people{dave} created automatically

my %h = (a => 1, b => 2, c => 3);

# Number of keys
my $count = scalar keys %h;

# Reverse a hash (values become keys)
my %rev = reverse %h;  # (1 => a, 2 => b, 3 => c)

# Merge hashes
my %merged = (%h, d => 4);

# Check if empty
print "empty\n" if !keys %h;

# Reset each() iterator
keys %h;  # resets iterator (v5.18+)

# Get min/max value
use List::Util qw(min max);
my ($min, $max) = (min(values %h), max(values %h));

my $score = 85;

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

# Statement modifier form
print "Pass\n" if $score >= 60;

# Note: it is 'elsif', NOT 'elseif'

my $logged_in = 0;

unless ($logged_in) {
    print "Please log in\n";
}
# Equivalent: if (!$logged_in) { ... }

# Statement modifier
print "Error\n" unless $ok;

# unless/else (often avoid for readability)
unless ($ok) {
    print "fail\n";
} else {
    print "pass\n";
}

# while loop
my $i = 0;
while ($i < 5) {
    print "$i\n";
    $i++;
}

# until = while NOT
my $done = 0;
until ($done) {
    $done = check_something();
}

# do-while style (runs at least once)
my $n = 0;
do {
    print $n++;
} while ($n < 3);

# Infinite loop
while (1) { last if $done; }

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

# foreach over a list (for and foreach are interchangeable)
foreach my $item (1, 2, 3) {
    print "$item\n";
}

# Range operator
for my $n (1 .. 10) {
    print "$n ";
}

# Uses default $_ variable
for (1 .. 5) {
    print "$_\n";
}

# last = break out of loop
for my $i (1 .. 10) {
    last if $i == 5;
    print "$i ";
}
# prints: 1 2 3 4

# next = skip to next iteration
for my $i (1 .. 5) {
    next if $i % 2 == 0;
    print "$i ";  # 1 3 5
}

# redo = re-run current iteration without re-checking
my $count = 0;
while (<$fh>) {
    $count++;
    redo if $count < 3;
}

# Labeled loops for nested control
OUTER: for my $i (1..3) {
    for my $j (1..3) {
        last OUTER if $i == 2 && $j == 2;
    }
}

use feature 'switch';
no warnings 'experimental::smartmatch';

my $val = 2;

given ($val) {
    when (1)       { print "one\n" }
    when (2)       { print "two\n" }
    when ([3, 4])  { print "three or four\n" }
    when (/^\d+$/) { print "a number\n" }
    default        { print "something else\n" }
}

# given/when is experimental; many prefer if/elsif
if    ($val == 1) { print "one\n" }
elsif ($val == 2) { print "two\n" }

my $str = "Hello, World";

# =~ binding operator applies a regex
if ($str =~ /World/) {
    print "Matched\n";
}

# Negated match
if ($str !~ /foo/) {
    print "No foo\n";
}

# Case-insensitive with /i
if ($str =~ /hello/i) {
    print "Found hello\n";
}

# Implicit match against $_
for ("cat", "dog", "bat") {
    print "$_\n" if /at/;  # cat, bat
}

my $str = "Hello, World";

# Replace first occurrence
$str =~ s/World/Perl/;  # Hello, Perl

# Replace all (g = global)
my $text = "a-b-c";
$text =~ s/-/_/g;  # a_b_c

# Case-insensitive replace
$str =~ s/hello/hi/i;

# Evaluate replacement as code (e)
my $s = "2+3";
$s =~ s/(\d+)\+(\d+)/$1 + $2/e;  # 5

# tr/// transliteration (character mapping)
my $dna = "ACGT";
$dna =~ tr/ACGT/TGCA/;  # TGCA

my $str = "2024-01-15";

# Numbered capture groups
if ($str =~ /(\d{4})-(\d{2})-(\d{2})/) {
    print "Year: $1\n";   # 2024
    print "Month: $2\n";  # 01
    print "Day: $3\n";    # 15
}

# Named captures (v5.10+)
if ($str =~ /(?<year>\d{4})-(?<month>\d{2})/) {
    print $+{year};   # 2024
    print $+{month};  # 01
}

# Capture all matches globally
my @nums = ($str =~ /(\d+)/g);  # (2024, 01, 15)

# Quantifiers
/a/      # exactly one
/a?/     # 0 or 1
/a*/     # 0 or more
/a+/     # 1 or more
/a{3}/   # exactly 3
/a{2,4}/ # 2 to 4
/a{3,}/  # 3 or more

# Greedy vs non-greedy (lazy)
/a.*/    # greedy (matches as much as possible)
/a.*?/   # non-greedy (matches as little as possible)

# Anchors
/^start/   # beginning of string
/end$/    # end of string
/\bword\b/ # word boundary
/\A/       # absolute start of string
/\z/       # absolute end of string

# Predefined classes
/\d/   # digit            [0-9]
/\D/   # non-digit
/\w/   # word char        [a-zA-Z0-9_]
/\W/   # non-word char
/\s/   # whitespace
/\S/   # non-whitespace
/./    # any char except newline

# Custom classes
/[aeiou]/    # any vowel
/[^0-9]/     # NOT a digit
/[a-z]/i     # case-insensitive range

# POSIX classes
/[[:alpha:]]/   # letters
/[[:digit:]]/   # digits
/[[:space:]]/   # whitespace
/[[:upper:]]/   # uppercase

# Common modifiers
/abc/i   # case-insensitive
/abc/g   # global (all matches)
/abc/m   # multiline (^/$ match line boundaries)
/abc/s   # single-line (. matches newline)
/abc/x   # extended (whitespace and comments)

# Extended mode for readability
my $re = qr{
    ^\d{4}     # year
    -
    \d{2}      # month
    -
    \d{2}      # day
}x;

# qr// pre-compiles a regex
my $pattern = qr/\bword\b/i;
if ($str =~ $pattern) { ... }

my $s = "Hello, World";

# length
print length($s);  # 12

# substr STRING, OFFSET, LENGTH, REPLACEMENT
print substr($s, 0, 5);   # Hello
print substr($s, 7);      # World
print substr($s, -5);     # World (negative offset)

# 4-argument substr (replace in place)
my $str = "Hello, World";
substr($str, 0, 5) = "Hi";  # Hi, World

# Lvalue form modifies original
substr($s, 0, 1) = "J";

my $s = "Hello, World";

# index STRING, SUBSTR, POSITION
my $pos  = index($s, "World");  # 7
my $pos2 = index($s, "o");      # 4 (first)
my $pos3 = index($s, "o", 5);   # 8 (from position 5)
my $not  = index($s, "xyz");    # -1 (not found)

# rindex searches from the end
my $last = rindex($s, "o");     # 8

# Count occurrences of 'l'
my $count = 0;
my $p = 0;
while (($p = index($s, "l", $p)) >= 0) {
    $count++;
    $p++;
}

my $line = "Hello\n";

# chomp removes the line terminator (safe)
chomp $line;   # $line = "Hello", returns 1

# chomp a whole array at once
my @lines = ("a\n", "b\n", "c\n");
chomp @lines;  # removes \n from all

# chop removes the last character (any char, risky)
my $s = "abc";
chop $s;  # "ab"

# chomp returns the count removed
my $cnt = chomp(my $x = "test\n");  # $cnt = 1

# chop returns the removed character
my $c = chop my $y = "xyz";  # $c = 'z'

# split /PATTERN/, EXPR, LIMIT
my @parts = split /,/, "a,b,c";      # (a, b, c)
my @lim   = split /,/, "a,b,c", 2;   # (a, "b,c")

# Split on whitespace
my @words = split /\s+/, "one two three";

# Split into characters
my @chars = split //, "abc";  # (a, b, c)

# join SEPARATOR, LIST
my $csv = join(",", "a", "b", "c");  # a,b,c
my $str = join(" - ", @parts);

# Empty separator joins without delimiter
my $joined = join("", @chars);  # abc

my $s = "Hello World";

print lc($s);       # hello world
print uc($s);       # HELLO WORLD
print lcfirst($s);  # hello World
print ucfirst($s);  # Hello World (already capped)

# In-string case modifiers (\L \U \u \l \E)
my $name = "Alice";
print "\L$name\E";  # alice  (\L starts, \E ends)
print "\U$name\E";  # ALICE
print "\u$name";     # Alice (capitalize first char)
print "\l$name";     # alice (lowercase first char)

# Title-case each word via regex
$s =~ s/(\w+)/\u\L$1/g;  # Hello World

# printf FORMAT, LIST (prints)
printf "Name: %s, Age: %d\n", "Alice", 30;
printf "Pi: %.2f\n", 3.14159;   # 3.14
printf "%5d\n", 42;             # '   42' (right-aligned)
printf "%-5d|\n", 42;           # '42   |' (left-aligned)
printf "%05d\n", 42;            # '00042' (zero-padded)

# sprintf returns the formatted string
my $date = sprintf("%04d-%02d-%02d", 2024, 1, 15);
# "2024-01-15"

# Common specifiers: %s %d %f %x %o %b %%
printf "Hex: %x, Oct: %o, Bin: %b\n", 255, 8, 5;

sub greet {
    my $name = shift;  # default: shifts from @_
    print "Hello, $name!\n";
}
greet("Alice");  # Hello, Alice!

# Subs are global by default
sub add {
    my ($a, $b) = @_;  # unpack arguments
    return $a + $b;
}
print add(2, 3);  # 5

# Forward declaration (define later)
sub compute;
print compute(4);

sub sum {
    my $total = 0;
    $total += $_ for @_;  # iterate all args
    return $total;
}
print sum(1, 2, 3, 4);  # 10

# Named arguments via hash
sub info {
    my %args = @_;
    print "Name: $args{name}\n";
    print "Age:  $args{age}\n";
}
info(name => "Alice", age => 30);

# Pass arrays/hashes by reference
sub total {
    my $arr = shift;
    my $sum = 0;
    $sum += $_ for @$arr;
    return $sum;
}

# Single return value
sub square { return $_[0] ** 2; }

# Return a list
sub min_max {
    my @nums = @_;
    my ($min, $max) = ($nums[0], $nums[0]);
    for (@nums) {
        $min = $_ if $_ < $min;
        $max = $_ if $_ > $max;
    }
    return ($min, $max);
}
my ($lo, $hi) = min_max(3, 1, 4, 1, 5);

# Implicit return (last expression)
sub name { "Alice" }  # returns "Alice"

# Void context (no return needed)
sub log_msg { print "log: $_[0]\n"; }

sub get_data {
    if (wantarray) {
        return (1, 2, 3);        # list context
    } elsif (defined wantarray) {
        return "scalar";         # scalar context
    } else {
        return;                  # void context
    }
}

my @list   = get_data();  # (1, 2, 3)
my $scalar = get_data();  # "scalar"
get_data();               # void

# localtime is context-sensitive
my $t = localtime();   # scalar: "Mon Jan  1 12:00:00 2024"
my @t = localtime();   # list: (sec, min, hour, mday, ...)

# scalar() forces scalar context
print scalar(localtime());

# Anonymous sub (coderef)
my $greet = sub {
    my $name = shift;
    return "Hi, $name";
};

print $greet->("Alice");   # Hi, Alice (preferred)
print &$greet("Bob");      # older syntax

# Closure: captures outer variable
sub make_counter {
    my $count = 0;
    return sub { return ++$count; };
}

my $c = make_counter();
print $c->();  # 1
print $c->();  # 2 (count persists)

# Pass subs as arguments
sub apply { my ($f, $x) = @_; return $f->($x); }
print apply(sub { $_ * 2 }, 21);  # 42

sub create_user {
    my %args = @_;
    # Apply defaults with defined-or
    $args{role}   //= 'user';
    $args{active} //= 1;
    return \%args;
}

my $user = create_user(
    name  => 'Alice',
    email => '[email protected]',
);
print $user->{role};   # user (default applied)

# Mix positional + named (named must come last)
sub point {
    my ($x, $y, %opts) = @_;
    print "($x, $y) color=$opts{color}\n";
}
point(1, 2, color => 'red');

# 3-argument open (recommended)
open(my $fh, '<', 'input.txt')
    or die "Cannot open input.txt: $!";

# Read the whole file
my @lines = <$fh>;
close $fh;

# Modes: < read, > write (truncate), >> append,
#        +< read/write, +> read/write (truncate)
open(my $out, '>', 'output.txt')
    or die "Cannot write: $!";

open(my $app, '>>', 'log.txt')
    or die "Cannot append: $!";

open(my $fh, '<', 'file.txt') or die $!;

# Line by line (memory efficient)
while (my $line = <$fh>) {
    chomp $line;
    print "Read: $line\n";
}

# Slurp entire file (undef the record separator)
local $/;
my $content = <$fh>;

# Read all lines into an array
my @lines = <$fh>;
close $fh;

# $. holds the current line number
open(my $f2, '<', 'file.txt') or die $!;
while (<$f2>) { print "$.: $_"; }

open(my $fh, '>', 'out.txt') or die $!;

print $fh "Hello, File!\n";
print $fh "Second line\n";

# Formatted write
printf $fh "%d: %s\n", 1, "first";

# Autoflush (no buffering)
use IO::Handle;
$fh->autoflush(1);

# Or via select
my $old = select($fh); $| = 1; select($old);

close $fh;  # flushes and closes

# <> reads from files in @ARGV, or STDIN if none
while (<>) {
    print "$.: $_";
}

# Equivalent to: while (my $line = <ARGV>) { ... }

# Read all of stdin (or all arg files)
my @input = <>;

# Specify files programmatically
@ARGV = ('file1.txt', 'file2.txt');
while (<>) {
    chomp;
    print ">> $_\n";
}

# In-place editing
$^I = '.bak';  # backup extension
while (<>) { s/foo/bar/g; print; }

# Lexical filehandle (modern, recommended)
open(my $fh, '<', $file) or die $!;

# Bareword filehandle (legacy, avoid)
open(IN, '<', $file) or die $!;
my $line = <IN>;
close IN;

# Standard handles: STDIN, STDOUT, STDERR
print STDOUT "to stdout\n";
my $err = <STDIN>;
warn "to stderr\n";   # STDERR is unbuffered

# Duplicate a handle
open(my $log, '>&', STDERR) or die $!;

# Open a filehandle to a string (in-memory)
open(my $mem, '>', \my $buffer) or die $!;
print $mem "stored\n";

use File::Slurper qw(read_text write_text append_text read_lines);

# Read entire file as a string
my $text = read_text('file.txt');

# Write a string to a file
write_text('out.txt', "Hello\n");

# Append to a file
append_text('log.txt', "New entry\n");

# Read all lines (without newlines by default)
my @lines = read_lines('data.csv');

# Binary files
use File::Slurper qw(read_binary write_binary);
my $bytes = read_binary('image.png');
write_binary('copy.png', $bytes);

opendir(my $dh, '.') or die "Cannot open dir: $!";

while (my $entry = readdir($dh)) {
    next if $entry =~ /^\./;   # skip dotfiles
    print "$entry\n";
}

# Or get all entries at once
rewinddir($dh);
my @entries = readdir($dh);

closedir $dh;

# Filter to only subdirectories
opendir(my $d, '.') or die $!;
my @dirs = grep { -d $_ } readdir($d);
closedir $d;

# glob expands filename wildcards
my @files = glob('*.txt');
my @perl  = glob('*.pl *.pm');

# Angle-bracket form (legacy)
my @same = <*.txt>;

# With a path
my @logs = glob('/var/log/*.log');

# Recursive globbing
use File::Glob qw(:bsd_glob);
my @all = bsd_glob('**/*.pm');  # needs :bsd_glob

# Capture flags: GLOB_ERR, GLOB_MARK (trailing / on dirs)
my @marked = bsd_glob('*', GLOB_MARK);

# Create a directory (default perms modified by umask)
mkdir 'newdir' or die $!;
mkdir 'newdir', 0755;  # explicit permissions

# Create nested directories
use File::Path qw(make_path remove_tree);
make_path('a/b/c');
make_path('x/y', { mode => 0755 });

# Remove a directory (must be empty)
rmdir 'emptydir' or die $!;

# Remove recursively
remove_tree('a');

# Change working directory
chdir '/tmp' or die $!;

# Get current directory
use Cwd qw(getcwd);
print getcwd();

use File::Find;

my @found;
find(sub {
    return if -d;                       # skip directories
    push @found, $File::Find::name
        if /\.pm\z/;
}, '.');

# finddepth visits directories after their contents
finddepth(sub {
    unlink $_ if -f and -M $_ > 30;     # delete old files
}, '/tmp/old');

# Multiple starting directories
find(\&wanted, qw(src lib t));

sub wanted {
    my $path = $File::Find::name;
    print "$path\n" if -f $path;
}

use Path::Tiny;

# Create a path object
my $path = path('/tmp/test.txt');

# File operations
$path->touch;
$path->spew("content\n");
my $content = $path->slurp;
my @lines   = $path->lines;

# Path manipulations
my $parent = $path->parent;
my $child  = $path->child('sub.txt');
my $abs    = $path->absolute;
my $rel    = $abs->relative('/tmp');

# Iterate directory contents
for my $f (path('.')->children) {
    print $f, "\n" if $f->is_file;
}

use File::Copy qw(copy move);

# Copy a file
copy('src.txt', 'dst.txt') or die $!;
copy('src.txt', 'dst.txt', 8192);  # buffer size

# Move / rename
move('old.txt', 'new.txt') or die $!;

# Portable paths via File::Spec
use File::Spec;
my $path = File::Spec->catfile('dir', 'file.txt');
my ($vol, $dir, $file) = File::Spec->splitpath($path);

# Delete files
unlink qw(a.txt b.txt c.txt);
my $removed = unlink grep { -f } glob('*.tmp');

my $scalar = 42;
my @arr = (1, 2, 3);
my %h   = (a => 1);

# Backslash creates a reference
my $sref = \$scalar;
my $aref = \@arr;
my $href = \%h;
my $cref = \&some_sub;

# Check what a reference points to
print ref($aref);  # ARRAY
print ref($href);  # HASH
print ref($sref);  # SCALAR
print ref($cref);  # CODE

# A non-reference returns ''
print ref("hi");   # (empty string)

my $aref = [1, 2, 3];
my $href = { a => 1, b => 2 };

# Whole array
my @arr = @$aref;          # or @{ $aref }
my $len = scalar @$aref;

# Single element via arrow
print $aref->[0];          # 1
print $#$aref;             # last index (2)

# Whole hash
my %h = %$href;
my @keys = keys %$href;

# Single value via arrow
print $href->{a};          # 1

# Block form for clarity
my @arr2 = @{ $aref };

# Anonymous array reference: [ ]
my $arr = [1, 2, 3];
print $arr->[0];  # 1

# Anonymous hash reference: { }
my $h = { name => 'Alice', age => 30 };
print $h->{name};

# Nested anonymous structures
my $data = {
    users => [ { name => 'a' }, { name => 'b' } ],
    count => 2,
};

# Anonymous subroutine
my $code = sub { print "hi\n" };

# Array of arrays (2D)
my $matrix = [
    [1, 2, 3],
    [4, 5, 6],
    [7, 8, 9],
];
print $matrix->[1][2];  # 6 (second arrow optional)

# Hash of hashes
my $config = {
    db  => { host => 'localhost', port => 3306 },
    app => { name => 'MyApp',     debug => 1 },
};
print $config->{db}{host};  # localhost

# Auto-vivification creates intermediate refs
my %tree;
$tree{a}{b}{c} = 1;  # builds the path automatically

my $arr = [[1, 2], [3, 4]];
my $h   = { users => [{ name => 'a' }] };

# Arrow between subscripts (second is optional)
print $arr->[0][1];           # 2
print $h->{users}[0]{name};   # a

# Arrow for coderef calls
my $greet = sub { "hi $_[0]" };
print $greet->("Bob");        # hi Bob

# Method calls on objects
$obj->method($arg);

# Slicing a dereferenced array
my @vals = @{ $h->{users} };

use Scalar::Util qw(reftype weaken);

my $aref = [];
my $href = {};
my $cref = sub {};

print ref($aref);       # ARRAY
print reftype($aref);   # ARRAY

# A blessed reference (object)
my $obj = bless {}, 'MyClass';
print ref($obj);        # MyClass
print reftype($obj);    # HASH  (the underlying type)

# Type checks
if (ref($r) eq 'ARRAY') { ... }
if (ref($r) eq 'HASH')  { ... }

# weaken avoids circular-reference memory leaks
weaken($r);

# use: runs at compile time, calls the module's import()
use strict;
use warnings;
use Data::Dumper;

# require: runs at runtime, does NOT call import()
require MyModule;

# Conditional loading (runtime)
if ($DEBUG) {
    require Carp;
    Carp->import('confess');
}

# use with version and import list
use v5.36;
use List::Util 1.33 qw(first sum max);

# use MODULE VERSION LIST
use Data::Dumper qw(Dumper);

# Add directories to the module search path
use lib '/home/me/lib';
use lib 'lib', 'local/lib';

# Locate a path relative to the script
use FindBin;
use lib "$FindBin::Bin/lib";

# Inspect the search path
print join("\n", @INC);

# Add at runtime (then require)
push @INC, '/path/to/lib';
require MyModule;

# Remove an entry
@INC = grep { !/local/ } @INC;

package MyModule;
use parent 'Exporter';

our @EXPORT    = qw(func1);          # exported by default
our @EXPORT_OK = qw(func2 func3);    # exported on request
our %EXPORT_TAGS = (
    all => [qw(func1 func2 func3)],
);

sub func1 { return "one"; }
sub func2 { return "two"; }
sub func3 { return "three"; }

1;  # a module must return a true value

# Usage in another file:
#   use MyModule;             # gets func1
#   use MyModule qw(func2);   # gets func2 only
#   use MyModule ':all';      # gets all three

# BEGIN runs at compile time
BEGIN {
    print "Compiled\n";
    require MyModule;
}

# END runs at exit (in LIFO order)
END {
    print "Cleaning up\n";
}

# Other phases: UNITCHECK, CHECK, INIT
INIT { print "Running\n"; }

# Compile-time constant definition
use constant DEBUG => 1;

# BEGIN to push a custom lib path early
BEGIN { push @INC, '/custom' }

package MyModule;
use strict;
use warnings;

our $VERSION = '1.00';

sub new {
    my $class = shift;
    return bless {}, $class;
}

sub method {
    my $self = shift;
    return "called";
}

1;  # required: modules must return a true value

# Switch back to the main package
package main;
my $obj = MyModule->new;
print $obj->method;

# use constant (compile-time)
use constant {
    PI    => 3.14159,
    MAX   => 100,
    DEBUG => 0,
};
print PI;  # 3.14159

# Readonly (lexically scoped, immutable)
use Readonly;
Readonly my $NAME => 'Alice';

# Const::Fast
use Const::Fast;
const my $count => 5;

# A constant is just a sub with an empty prototype
sub MAX_CONNECTIONS () { 10 }
print MAX_CONNECTIONS;  # 10

package Animal;
use strict;
use warnings;

sub new {
    my ($class, %args) = @_;
    my $self = { name => $args{name}, sound => 'generic' };
    return bless $self, $class;
}

sub name { shift->{name} }

1;

# bless associates a reference with a package (the class).
# $self is a hash ref blessed into Animal.

package Point;
use strict;
use warnings;

sub new {
    my ($class, $x, $y) = @_;
    my $self = { x => $x, y => $y };
    return bless $self, $class;
}

# Usage (arrow syntax preferred)
my $p = Point->new(3, 4);

# Indirect syntax ( discouraged)
my $p2 = new Point(3, 4);

# Named-argument constructor
sub new_named {
    my ($class, %args) = @_;
    return bless \%args, $class;
}

package Point;
sub new { ... }

# Instance method: first arg is the object
sub distance {
    my ($self, $other) = @_;
    my $dx = $self->{x} - $other->{x};
    my $dy = $self->{y} - $other->{y};
    return sqrt($dx**2 + $dy**2);
}

# Getter
sub x { my $self = shift; return $self->{x}; }

# Setter (chainable)
sub set_x {
    my ($self, $x) = @_;
    $self->{x} = $x;
    return $self;
}

# Class method
sub count { our $count; return ++$count }

package Dog;
use parent 'Animal';

sub new {
    my ($class, %args) = @_;
    my $self = $class->SUPER::new(%args);  # call parent
    $self->{breed} = $args{breed};
    return $self;
}

sub speak {
    my $self = shift;
    return "Woof!";
}

# Direct @ISA (lower-level)
package Cat;
our @ISA = ('Animal');

# Multiple inheritance
package Duck;
use parent qw(Flyable Animal);

# Hand-written accessor (getter + setter)
sub name {
    my $self = shift;
    if (@_) { $self->{name} = shift; return $self; }
    return $self->{name};
}

# Class::Accessor generates them
package User;
use parent 'Class::Accessor';
__PACKAGE__->mk_accessors(qw(name email age));

# Usage
my $u = User->new({ name => 'Alice' });
$u->name;          # get
$u->name('Bob');   # set

# Moo / Moose generate accessors declaratively
has name => (is => 'rw');

package FileHandle::Custom;
sub new {
    my ($class, $file) = @_;
    open(my $fh, '<', $file) or die $!;
    return bless { fh => $fh }, $class;
}

sub DESTROY {
    my $self = shift;
    close $self->{fh} if $self->{fh};
    # auto-called when refcount reaches 0
}

# AUTOLOAD catches undefined method calls
sub AUTOLOAD {
    my $self = shift;
    our $AUTOLOAD;
    my $method = $AUTOLOAD;
    $method =~ s/.*:://;
    return $self->{$method};  # treat as accessor
}

my $f = 'file.txt';

print "exists\n"     if -e $f;   # exists
print "regular\n"    if -f $f;   # plain file
print "dir\n"        if -d $f;   # directory
print "symlink\n"    if -l $f;   # symbolic link
print "socket\n"     if -S $f;   # socket
print "pipe\n"       if -p $f;   # named pipe (FIFO)
print "char dev\n"   if -c $f;   # character device
print "block dev\n"  if -b $f;   # block device

# Stack tests (uses the same stat cache)
print "regular file\n" if -f -e $f;

# _ reuses the last stat result
print "size: ", -s _ if -e $f;

my $f = 'script.pl';

print "readable\n"   if -r $f;  # effective uid can read
print "writable\n"   if -w $f;  # effective uid can write
print "executable\n" if -x $f;  # effective uid can exec
print "owned\n"      if -o $f;  # owned by effective uid

# Real uid variants (rarely needed)
print "real read\n"  if -R $f;
print "real write\n" if -W $f;
print "real exec\n"  if -X $f;

# setuid / setgid / sticky
print "setuid\n"  if -u $f;
print "setgid\n"  if -g $f;
print "sticky\n"  if -k $f;

my $f = 'data.bin';

# -s returns size in bytes (or undef if missing)
my $size = -s $f;
print "Size: $size bytes\n";

# Empty file
if (-z $f) { print "empty\n"; }
# Non-empty (size > 0)
if (-s $f) { print "has data\n"; }

# Human-readable size
use Number::Bytes::Human qw(format_bytes);
print format_bytes(-s $f), "\n";

# stat() for full detail
my @st = stat($f);
print "Size: $st[7] bytes\n";  # index 7 is size

my $f = 'file.txt';

# All return age in days since script start ($^T)
print -M $f;  # modification age (days)
print -A $f;  # access age (days)
print -C $f;  # inode-change age (days)

# Older than 30 days?
if (-M $f > 30) { print "old file\n"; }

# Modified today?
if (-M $f < 1) { print "modified today\n"; }

# Epoch seconds via stat
my @st = stat($f);
my $mtime = $st[9];   # mtime (epoch)
my $atime = $st[8];   # atime (epoch)
my $ctime = $st[10];  # ctime (epoch)

my $f = 'file.txt';

# -T text file, -B binary file
if (-T $f) { print "text\n"; }
if (-B $f) { print "binary\n"; }

# Perl heuristically decides from the first block

# Filter a directory to text files only
opendir(my $dh, '.');
my @text_files = grep { -f && -T } readdir($dh);
closedir $dh;

# Note: empty files count as text

# Proper MIME detection
use File::MimeInfo::Magic;
print mimetype($f);

my $f = 'file.txt';

# stat returns a 13-element list
my @s = stat($f);
# 0 dev, 1 ino, 2 mode, 3 nlink, 4 uid, 5 gid,
# 6 rdev, 7 size, 8 atime, 9 mtime, 10 ctime,
# 11 blksize, 12 blocks

my $size  = $s[7];
my $perms = sprintf "%04o", $s[2] & 07777;

# lstat does NOT follow symlinks
my @ls = lstat($f);

# stat on an open filehandle
my @sf = stat($fh);

# _ reuses the last stat result (no new syscall)
print -s _ if -e $f;

# Install a module from the command line:
#   cpanm DBI
#   cpanm Mojolicious
#   cpanm --interactive Module::Name

# Install a specific version range
#   cpanm DBI~">=1.6"

# Install from a git repository
#   cpanm https://github.com/user/Mod.git

# Install dependencies from a cpanfile
#   cpanm --installdeps .

# Install into a local directory
#   cpanm -l extlib DBI

# Verbose output
#   cpanm -v DBI

# cpanfile declares runtime and test dependencies
requires 'perl', '5.014';
requires 'DBI'          => '1.6';
requires 'Mojolicious'  => '9.0';

# Phase-specific dependencies
on develop => sub {
    requires 'Test::Pod';
    requires 'Test::Perl::Critic';
};

on test => sub {
    requires 'Test::More'   => '0.98';
    requires 'Test::Exception';
};

recommends 'JSON::XS';
conflicts 'Old::Module';

# Carton manages a locked dependency tree
# Install Carton:  cpanm Carton

# Commands (shell):
#   carton install        # install from cpanfile
#   carton install DBI    # add a module
#   carton exec ./app.pl  # run with local deps
#   carton bundle         # vendor tarballs
#   carton show           # list installed

# cpanfile.snapshot locks exact versions
# local/ holds the installed modules

# In your code, ensure the lib path:
use lib 'local/lib/perl5';
use DBI;

# Install into a local directory
#   cpanm -l extlib DBI

# Then use it in your script:
use lib 'extlib/lib/perl5';
use DBI;

# Bootstrap local::lib
#   cpanm --local-lib=~/perl5 local::lib
use local::lib '~/perl5';

# Find a module's installed path
use Module::Util qw(module_path);
my $path = module_path('DBI');

# Check an installed version from the CLI:
#   perl -MDBI -e 'print $DBI::VERSION'

# App::perlbrew manages multiple perl installations
# Shell commands:
#   perlbrew init
#   perlbrew install perl-5.38.0
#   perlbrew switch perl-5.38.0
#   perlbrew use perl-5.36.0
#   perlbrew list
#   perlbrew install-cpanm

# Install a CPAN module into a specific perl
#   perlbrew exec --with perl-5.38 cpanm DBI

# Use a specific perl in a script's shebang:
#   #!/home/user/perl5/perlbrew/perls/perl-5.38/bin/perl
use v5.38;
use strict;
use warnings;

# Bootstrap local::lib (shell):
#   cpanm --local-lib=~/perl5 local::lib

# In your script, use the local library:
use local::lib;

# Or specify a path explicitly
use local::lib '/path/to/libs';

# Set up environment in your shell rc:
#   eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"

# Verify @INC includes your local path
print "$_\n" for @INC;

# Now install modules locally:
#   cpanm -l ~/perl5 Some::Module

# die throws an exception
open(my $fh, '<', 'missing.txt')
    or die "Cannot open: $!";  # $! is the system error

# A trailing newline suppresses "at file line N"
die "Custom error\n";

# die with a reference (object exception)
die MyException->new(message => 'oops');

# Default die appends location info
die "Something bad happened";
# prints: Something bad happened at script.pl line 3.

# warn prints to STDERR but continues
warn "This is a warning: $!";

# Trailing newline omits location
warn "Just a note\n";

# Disable a warning category locally
{
    no warnings 'uninitialized';
    print $undefined;  # no warning
}

# Custom __WARN__ handler
$SIG{__WARN__} = sub {
    my $msg = shift;
    log_warning($msg);
    print STDERR $msg;
};

# eval BLOCK (modern, recommended)
eval {
    risky_operation();
    die "failed";
};
if ($@) {
    print "Caught: $@\n";
}

# eval STRING parses and runs code (avoid; slow & unsafe)
eval '\$x = 1 + 2';

# eval returns the last expression on success
my $result = eval { compute() };
my $error  = $@;  # check immediately

# Always check $@ right after eval
# (or use Try::Tiny for safety)

# $@ - the last eval error
eval { die "boom" };
print $@ if $@;

# $! - errno (system errors)
open(my $fh, '<', 'x') or die "open: $!";

# $! in numeric vs string context
print int($!);    # errno number (e.g. 2)
print "$!";       # error string (e.g. "No such file")

# $? - child process status
system("ls");
print $? >> 8;    # exit code

# $^E - extended error (platform-specific)
print $^E;

use Try::Tiny;

try {
    risky_code();
    die "explicit fail";
} catch {
    warn "caught: $_";  # $_ is the error, not $@
} finally {
    cleanup();           # always runs
};

# Return value flows through
my $val = try {
    compute_value();
} catch {
    default_value();
};

# Note: inside catch use $_, not $@

package MyException;
use overload '""' => sub { $_[0]->{message} };

sub new {
    my ($class, %args) = @_;
    return bless { message => $args{message} }, $class;
}

1;

# Usage
eval {
    die MyException->new(message => 'Custom error');
};
if (ref($@) && ref($@)->isa('MyException')) {
    print "Custom: $@\n";
}

# Or use Exception::Class for richer features
use Exception::Class ('MyEx' => { fields => ['detail'] });
MyEx->throw(detail => 'something');

use DBI;

my $dbh = DBI->connect(
    'DBI:mysql:database=test;host=localhost',
    'user', 'password',
    { RaiseError => 1, AutoCommit => 1 }
) or die "Connect failed: $DBI::errstr";

# Always disconnect when done
$dbh->disconnect;

# Other drivers
#   DBI:mysql:    DBI:Pg:    DBI:SQLite:    DBI:Oracle:
my $sqlite = DBI->connect('DBI:SQLite:dbname=test.db');

my $sth = $dbh->prepare('SELECT id, name FROM users WHERE age > ?');
$sth->execute(18);

# Fetch one row at a time as an array
while (my @row = $sth->fetchrow_array) {
    print "id=$row[0], name=$row[1]\n";
}

# Fetch as a hashref
while (my $row = $sth->fetchrow_hashref) {
    print $row->{name}, "\n";
}

# Fetch all rows
my $rows = $sth->fetchall_arrayref;

$sth->finish;  # release statement handle early

# All rows as an array of arrays
my $rows = $dbh->selectall_arrayref('SELECT * FROM users');

# All rows keyed by a column
my $by_id = $dbh->selectall_hashref(
    'SELECT * FROM users', 'id'
);

# Single value
my $count = $dbh->selectrow_array('SELECT COUNT(*) FROM users');

# Single row as a hash
my $row = $dbh->selectrow_hashref(
    'SELECT * FROM users WHERE id = ?', undef, 5
);

# Disable AutoCommit to begin a transaction
$dbh->{AutoCommit} = 0;

eval {
    $dbh->do('INSERT INTO accounts ...');
    $dbh->do('UPDATE accounts SET balance = ...');
    $dbh->commit;
};
if ($@) {
    $dbh->rollback;
    die "Transaction failed: $@";
}

# begin_work is cleaner (auto-resets AutoCommit)
$dbh->begin_work;
eval { ...; $dbh->commit; };
$dbh->rollback if $@;

# ALWAYS use placeholders to prevent SQL injection
my $sth = $dbh->prepare(
    'INSERT INTO users (name, age) VALUES (?, ?)'
);
$sth->execute('Alice', 30);
$sth->execute('Bob', 25);

# Named placeholders (some drivers)
#   :name, :age
$dbh->do('INSERT ... VALUES (:name, :age)', undef,
    { name => 'Alice', age => 30 });

# Bulk insert
my @rows = (['a', 1], ['b', 2]);
$sth->execute(@$_) for @rows;

# quote() exists but prefer placeholders
my $q = $dbh->quote("O'Brien");

# RaiseError: die on error (recommended)
my $dbh = DBI->connect($dsn, $u, $p,
    { RaiseError => 1, PrintError => 0 });

# Manual checking (without RaiseError)
my $rv = $dbh->do('UPDATE ...');
unless ($rv) { die $dbh->errstr; }

# Error info: $dbh->err, errstr, state
print $dbh->err;      # error code
print $dbh->errstr;   # error message
print $dbh->state;    # SQLSTATE

# HandleError callback for custom handling
$dbh->{HandleError} = sub {
    my $msg = shift;
    log_error($msg);
    return 0;  # 0 = propagate (die)
};

# @ARGV holds command-line args (script name NOT included)
my $file = $ARGV[0];
my @args = @ARGV;

# Number of arguments
my $n = scalar @ARGV;

# Process args one at a time
while (@ARGV) {
    my $arg = shift @ARGV;
    print "Arg: $arg\n";
}

# Capture all remaining args
my @rest = @ARGV;

# The script's own name is in $0
print "Running $0\n";

use Getopt::Long;

my ($verbose, $name, $count, @files, $help);
GetOptions(
    'verbose|v'  => \$verbose,
    'name=s'     => \$name,
    'count=i'    => \$count,
    'files=s@'   => \@files,
    'help|h'     => \$help,
) or die "Usage: $0 [--verbose] [--name=X]\n";

exit print_usage() if $help;
print "verbose=$verbose name=$name count=$count\n";

# Run: perl script.pl -v --name=Alice --count=3 file1 file2

# <> reads from files in @ARGV, or STDIN if empty
while (my $line = <>) {
    chomp $line;
    print "processed: $line\n";
}

# Run: perl script.pl file1.txt file2.txt
# Run: cat file | perl script.pl

# $ARGV is the current filename being read
# @ARGV is consumed as files are processed

# Reset to read a new set of files
@ARGV = @new_files;
while (<>) { ... }

# In-place edit with backup
$^I = '.bak';
while (<>) { s/foo/bar/g; print; }

# exit with a status (0 = success)
exit 0;    # success
exit 1;    # general error
exit 255;  # out-of-range wraps (255 == -1)

# die sets a non-zero exit
eval { die "error\n" };
exit 1 if $@;

# Check a child's exit status
system("ls");
my $code   = $? >> 8;    # exit value
my $signal = $? & 127;   # signal that killed it
my $core   = ($? & 128); # core dump flag
print "exit=$code signal=$signal\n";

# END blocks still run on exit
END { cleanup(); }

# __DATA__ (or __END__) marks the end of code
# <DATA> reads from this section in the same file
while (my $line = <DATA>) {
    chomp $line;
    print "[$line]\n";
}

__DATA__
line 1
line 2
line 3

# __END__ behaves the same in a script;
# in a module use __DATA__ so the section is accessible.
# Data::Section supports multiple named sections.

# -e execute code
#   perl -e 'print "hello\n"'

# -n loop over input (no auto-print)
#   perl -ne 'print if /pattern/' file.txt

# -p loop and auto-print (like sed)
#   perl -pe 's/foo/bar/g' file.txt

# -i in-place edit (with optional backup suffix)
#   perl -i.bak -pe 's/old/new/g' *.txt

# -l auto chomp + add newline on print
# -a autosplit into @F (default whitespace)
# -F set the delimiter for -a
#   perl -F, -ane 'print "$F[1]\n"' data.csv

# printf FORMAT, LIST
printf "Name: %s\n", "Alice";
printf "Age: %d\n", 30;
printf "Pi: %.2f\n", 3.14159;   # 3.14
printf "Hex: %x\n", 255;         # ff
printf "Oct: %o\n", 8;           # 10
printf "Bin: %b\n", 5;           # 101
printf "Sci: %e\n", 123456;      # 1.234560e+05

# Width and alignment
printf "%10s|\n", "hi";    # '        hi|' (right)
printf "%-10s|\n", "hi";   # 'hi        |' (left)
printf "%05d\n", 42;       # '00042' (zero-pad)
printf "%+d\n", 42;        # '+42' (force sign)

# sprintf returns the formatted string
my $date = sprintf("%04d-%02d-%02d", 2024, 1, 15);
# "2024-01-15"

my $log = sprintf("[%s] %s: %s",
    scalar localtime, "INFO", "message");

# String padding
my $right = sprintf("%20s", "hi");
my $left  = sprintf("%-20s|", "hi");

# Multiple formatted values
my $row = sprintf("%-10s %5d %8.2f",
    "apple", 3, 1.50);

# Literal percent
my $pct = sprintf("%d%%", 50);  # "50%"

# Define a report format for STDOUT
format STDOUT =
@<<<<<<<<<<<<<< @>>>>>>
$name,           $amount
.

my $name   = "Alice";
my $amount = 1234.56;
write;  # outputs the formatted line: Alice           1234.56

# Optional top-of-page (header) format
format STDOUT_TOP =
Name           Amount
----------------------
.

# $~ sets the format name, $^ sets the top-of-page format

# Format field holders:
# @<<<   left-justified  (min width = number of chars)
# @>>>   right-justified
# @|||   centered
# @###.## numeric (right-justified, with decimals)
# @*     multiline (takes whole lines)

format REPORT =
@<<<<<<<<<<<<<<<<  @>>>>.##
$text,              $num
.

# ~  suppresses a blank line if fields are empty
# ~~ repeats the line until a field is exhausted
format BLOCK =
~~ ^<<<<<<<<<<<<<<<<<
$text
.

# ^  enables word-wrap into the field

# printf / sprintf specifiers
%%   literal percent
%s   string
%c   character (from code point)
%d   signed integer
%u   unsigned integer
%f   floating point
%e   scientific (lowercase)
%E   scientific (uppercase)
%x   hex (lowercase)    %X hex (uppercase)
%o   octal
%b   binary

# Flags: - + 0 space #
printf "%-10s|%+d|%05d| %#x", "x", 5, 5, 255;

# Width and precision: %N.M
printf "%.3f", 3.14159;   # 3.142
printf "%8.2f", 3.14159;  # '    3.14'

# Right-align (default for numbers)
my $r = sprintf("%10s", "hi");    # '        hi'

# Left-align with '-'
my $l = sprintf("%-10s|", "hi");  # 'hi        |'

# Zero-pad numbers
my $z = sprintf("%05d", 42);      # '00042'

# Center manually
sub center {
    my ($s, $w) = @_;
    my $pad = int(($w - length($s)) / 2);
    return ' ' x $pad . $s . ' ' x ($w - $pad - length($s));
}
print center("Title", 20);

# Replace spaces with another char
my $dashed = sprintf("%20s", "x");
$dashed =~ tr/ /-/;  # '-------------------x'