PerlPad — A Real Text Editor

#!/usr/bin/env perl
# =============================================================================
#  perl_gui_04_app.pl  —  GUI Tutorial Part 4: A Complete Application
#  Companion to: perl_mac_guide.md  Section 28–29
#
#  Run with:  perl perl_gui_04_app.pl
#  Requires:  Perl/Tk  (cpanm Tk)
#
#  This is a fully-functional TEXT EDITOR demonstrating:
#    • Complete menu bar (File, Edit, View, Help)
#    • File open / save / save-as with dirty-state tracking
#    • Find & Replace dialog (Toplevel, modal)
#    • Keyboard shortcuts (macOS Cmd key)
#    • Word wrap toggle
#    • Font size control
#    • Line number display
#    • Status bar (line/column, word count, file name)
#    • Window close intercept (WM_DELETE_WINDOW)
#    • after() timer for live status updates
#    • Proper application architecture (state separated from UI)
# =============================================================================
use strict;
use warnings;
use Tk;
use Tk::Text;

# =============================================================================
# Application State  — all data lives here, not inside callbacks
# =============================================================================
my $current_file  = undef;     # Path of open file, undef if new
my $modified      = 0;         # Has the document changed since last save?
my $word_wrap     = 1;         # Word wrap on/off
my $font_size     = 13;        # Current font size
my $status_msg    = "New Document";
my $line_col_msg  = "Ln 1, Col 1";
my $word_count    = "0 words";
my $show_line_nums= 1;

# =============================================================================
# Main Window
# =============================================================================
my $mw = MainWindow->new;
$mw->title("PerlPad — New Document");
$mw->geometry("820x640+60+40");
$mw->configure(-background => "#1e1e1e");

# Intercept the window close button  (Section 28, 29)
$mw->protocol("WM_DELETE_WINDOW", \&cmd_quit);

# =============================================================================
# Build the UI
# =============================================================================
build_menu();
build_toolbar();
build_editor_area();
build_status_bar();
bind_shortcuts();

# Start the live status updater
$mw->after(500, \&update_status_loop);

# Focus the text area
$mw->after(100, sub { $main::editor->focus });

MainLoop;

# =============================================================================
# Menu Bar  (Section 26)
# =============================================================================
sub build_menu {
    my $mb = $mw->Menu;
    $mw->configure(-menu => $mb);

    # ── File ──────────────────────────────────────────────────────────────────
    my $file = $mb->cascade(-label => "File", -underline => 0, -tearoff => 0);
    $file->command(-label => "New",       -accelerator => "Cmd+N", -command => \&cmd_new);
    $file->command(-label => "Open…",     -accelerator => "Cmd+O", -command => \&cmd_open);
    $file->separator;
    $file->command(-label => "Save",      -accelerator => "Cmd+S", -command => \&cmd_save);
    $file->command(-label => "Save As…",  -accelerator => "Cmd+Shift+S", -command => \&cmd_save_as);
    $file->separator;
    $file->command(-label => "Quit",      -accelerator => "Cmd+Q", -command => \&cmd_quit);

    # ── Edit ──────────────────────────────────────────────────────────────────
    my $edit = $mb->cascade(-label => "Edit", -underline => 0, -tearoff => 0);
    $edit->command(-label => "Undo",      -accelerator => "Cmd+Z", -command => \&cmd_undo);
    $edit->separator;
    $edit->command(-label => "Cut",       -accelerator => "Cmd+X", -command => \&cmd_cut);
    $edit->command(-label => "Copy",      -accelerator => "Cmd+C", -command => \&cmd_copy);
    $edit->command(-label => "Paste",     -accelerator => "Cmd+V", -command => \&cmd_paste);
    $edit->separator;
    $edit->command(-label => "Select All",-accelerator => "Cmd+A", -command => \&cmd_select_all);
    $edit->separator;
    $edit->command(-label => "Find / Replace…", -accelerator => "Cmd+F", -command => \&cmd_find);

    # ── View ──────────────────────────────────────────────────────────────────
    my $view = $mb->cascade(-label => "View", -tearoff => 0);
    $view->checkbutton(-label => "Word Wrap",      -variable => \$word_wrap,
                       -command => \&apply_wrap);
    $view->checkbutton(-label => "Line Numbers",   -variable => \$show_line_nums,
                       -command => \&toggle_line_numbers);
    $view->separator;
    $view->command(-label => "Increase Font",  -accelerator => "Cmd++", -command => sub { change_font(+1) });
    $view->command(-label => "Decrease Font",  -accelerator => "Cmd+-", -command => sub { change_font(-1) });
    $view->command(-label => "Reset Font",                               -command => sub { $font_size = 13; apply_font() });

    # ── Help ──────────────────────────────────────────────────────────────────
    my $help = $mb->cascade(-label => "Help", -tearoff => 0);
    $help->command(-label => "About PerlPad", -command => \&show_about);
    $help->command(-label => "Keyboard Shortcuts", -command => \&show_shortcuts);
}

# =============================================================================
# Toolbar
# =============================================================================
sub build_toolbar {
    my $tb = $mw->Frame(-background => "#2d2d2d", -relief => "flat")->pack(-fill => "x");

    my @btns = (
        ["New",    \&cmd_new ],
        ["Open",   \&cmd_open],
        ["Save",   \&cmd_save],
        ["|",      undef     ],
        ["Undo",   \&cmd_undo],
        ["Cut",    \&cmd_cut ],
        ["Copy",   \&cmd_copy],
        ["Paste",  \&cmd_paste],
        ["|",      undef     ],
        ["Find",   \&cmd_find],
    );

    for my $b (@btns) {
        my ($label, $cmd) = @$b;
        if ($label eq "|") {
            $tb->Label(-text => " ", -background => "#555", -width => 1)->pack(-side => "left", -padx => 3, -fill => "y");
        } else {
            $tb->Button(
                -text             => $label,
                -font             => "Helvetica 10",
                -background       => "#2d2d2d",
                -foreground       => "#cccccc",
                -activebackground => "#3a3a3c",
                -activeforeground => "white",
                -relief           => "flat",
                -padx             => 8, -pady => 4,
                -command          => $cmd,
            )->pack(-side => "left");
        }
    }

    # Font size spinbox area
    $tb->Label(-text => " Font: ", -font => "Helvetica 10",
               -foreground => "#aaa", -background => "#2d2d2d"
              )->pack(-side => "left", -padx => 4);
    $tb->Button(-text => "−", -font => "Helvetica 12 bold",
                -background => "#2d2d2d", -foreground => "#cccccc",
                -activebackground => "#3a3a3c",
                -relief => "flat", -padx => 4, -pady => 2,
                -command => sub { change_font(-1) })->pack(-side => "left");
    $tb->Label(-textvariable => \$font_size,
               -font => "Helvetica 10 bold", -foreground => "white",
               -background => "#2d2d2d", -width => 3
              )->pack(-side => "left");
    $tb->Button(-text => "+", -font => "Helvetica 12 bold",
                -background => "#2d2d2d", -foreground => "#cccccc",
                -activebackground => "#3a3a3c",
                -relief => "flat", -padx => 4, -pady => 2,
                -command => sub { change_font(+1) })->pack(-side => "left");
}

# =============================================================================
# Editor Area — Text widget + optional line number bar
# =============================================================================
our $editor;          # Global so subroutines can access it
our $line_num_text;   # Line number sidebar

sub build_editor_area {
    my $edit_frame = $mw->Frame(-background => "#1e1e1e")->pack(
        -fill => "both", -expand => 1
    );

    # Line number sidebar (a read-only Text widget)
    $line_num_text = $edit_frame->Text(
        -width      => 5,
        -font       => "Courier $font_size",
        -background => "#2d2d2d",
        -foreground => "#666666",
        -relief     => "flat",
        -state      => "disabled",
        -cursor     => "arrow",
    )->pack(-side => "left", -fill => "y");

    # Main editor
    $editor = $edit_frame->Text(
        -font       => "Courier $font_size",
        -background => "#1e1e1e",
        -foreground => "#d4d4d4",
        -insertbackground => "white",   # Cursor color
        -selectbackground => "#264f78",
        -selectforeground => "white",
        -undo       => 1,               # Enable built-in undo stack
        -wrap       => ($word_wrap ? "word" : "none"),
        -relief     => "flat",
        -padx       => 8,
        -pady       => 4,
    )->pack(-side => "left", -fill => "both", -expand => 1);

    # Scrollbar (shared between editor and line numbers)
    my $vsb = $edit_frame->Scrollbar(
        -command    => sub { $editor->yview(@_); $line_num_text->yview(@_) },
        -background => "#2d2d2d",
        -troughcolor=> "#1e1e1e",
    )->pack(-side => "right", -fill => "y");

    $editor->configure(-yscrollcommand => sub {
        $vsb->set(@_);
        update_line_numbers();
    });

    # Track modifications
    $editor->bind("<<Modified>>", \&on_text_modified);
    $editor->bind("<KeyRelease>", \&on_key_release);

    # Syntax-style tag for headings (simple demo)
    $editor->tagConfigure("comment",  -foreground => "#6a9955");
    $editor->tagConfigure("keyword",  -foreground => "#569cd6");
    $editor->tagConfigure("string",   -foreground => "#ce9178");
    $editor->tagConfigure("number",   -foreground => "#b5cea8");

    # Seed with welcome content
    $editor->insert("1.0", welcome_text());
    $editor->edit_modified(0);
    update_line_numbers();
}

# =============================================================================
# Status Bar
# =============================================================================
sub build_status_bar {
    my $sb = $mw->Frame(-background => "#007aff", -height => 24)->pack(
        -fill => "x", -side => "bottom"
    );

    $sb->Label(
        -textvariable => \$status_msg,
        -font         => "Helvetica 10",
        -foreground   => "white",
        -background   => "#007aff",
        -anchor       => "w",
    )->pack(-side => "left", -padx => 10);

    $sb->Label(
        -textvariable => \$word_count,
        -font         => "Helvetica 10",
        -foreground   => "white",
        -background   => "#007aff",
    )->pack(-side => "right", -padx => 20);

    $sb->Label(
        -textvariable => \$line_col_msg,
        -font         => "Courier 10",
        -foreground   => "white",
        -background   => "#007aff",
    )->pack(-side => "right", -padx => 10);
}

# =============================================================================
# Keyboard Shortcuts  (Section 25, 29)
# =============================================================================
sub bind_shortcuts {
    # On macOS, Command = Meta in Perl/Tk
    $mw->bind("<Meta-n>",       \&cmd_new);
    $mw->bind("<Meta-o>",       \&cmd_open);
    $mw->bind("<Meta-s>",       \&cmd_save);
    $mw->bind("<Meta-S>",       \&cmd_save_as);
    $mw->bind("<Meta-q>",       \&cmd_quit);
    $mw->bind("<Meta-z>",       \&cmd_undo);
    $mw->bind("<Meta-f>",       \&cmd_find);
    $mw->bind("<Meta-a>",       \&cmd_select_all);
    $mw->bind("<Meta-equal>",   sub { change_font(+1) });   # Cmd+=
    $mw->bind("<Meta-minus>",   sub { change_font(-1) });   # Cmd+-
    $mw->bind("<Meta-w>",       \&cmd_quit);
}

# =============================================================================
# File Operations
# =============================================================================
sub cmd_new {
    return unless confirm_save_if_modified();
    $editor->delete("1.0", "end");
    $editor->insert("1.0", "");
    $editor->edit_modified(0);
    $current_file = undef;
    $modified     = 0;
    $mw->title("PerlPad — New Document");
    $status_msg = "New Document";
    update_line_numbers();
}

sub cmd_open {
    return unless confirm_save_if_modified();

    my $file = $mw->getOpenFile(
        -title      => "Open File",
        -initialdir => $ENV{HOME} // ".",
        -filetypes  => [
            ["Text Files",  ".txt" ],
            ["Perl Scripts",".pl"  ],
            ["All Files",   "*"    ],
        ],
    );
    return unless $file;

    eval {
        open(my $fh, "<", $file) or die "Cannot read: $!";
        my $content = do { local $/; <$fh> };
        close($fh);

        $editor->delete("1.0", "end");
        $editor->insert("1.0", $content);
        $editor->edit_modified(0);
        $current_file = $file;
        $modified     = 0;
        $mw->title("PerlPad — $file");
        $status_msg = "Opened: $file";
        update_line_numbers();
    };
    if ($@) {
        $mw->messageBox(-title => "Error", -message => "Could not open:\n$@",
                        -type => "OK", -icon => "error");
    }
}

sub cmd_save {
    return cmd_save_as() unless $current_file;
    save_to_file($current_file);
}

sub cmd_save_as {
    my $file = $mw->getSaveFile(
        -title       => "Save As",
        -initialdir  => $ENV{HOME} // ".",
        -initialfile => ($current_file // "untitled.txt"),
        -filetypes   => [
            ["Text Files",  ".txt"],
            ["Perl Scripts",".pl" ],
            ["All Files",   "*"   ],
        ],
    );
    return unless $file;
    $current_file = $file;
    save_to_file($file);
}

sub save_to_file {
    my ($file) = @_;
    eval {
        open(my $fh, ">", $file) or die "Cannot write: $!";
        my $content = $editor->get("1.0", "end");
        print $fh $content;
        close($fh);
        $editor->edit_modified(0);
        $modified   = 0;
        $mw->title("PerlPad — $file");
        $status_msg = "Saved: $file";
    };
    if ($@) {
        $mw->messageBox(-title => "Error", -message => "Could not save:\n$@",
                        -type => "OK", -icon => "error");
    }
}

sub confirm_save_if_modified {
    return 1 unless $modified;
    my $ans = $mw->messageBox(
        -title   => "Unsaved Changes",
        -message => "Save changes before continuing?",
        -type    => "YesNoCancel",
        -icon    => "question",
    );
    return 0 if $ans eq "Cancel";
    cmd_save() if $ans eq "Yes";
    return 1;
}

sub cmd_quit {
    return unless confirm_save_if_modified();
    exit;
}

# =============================================================================
# Edit Operations
# =============================================================================
sub cmd_undo        { $editor->edit_undo }
sub cmd_cut         { $editor->cut }
sub cmd_copy        { $editor->copy }
sub cmd_paste       { $editor->paste }
sub cmd_select_all  { $editor->selectAll }

# =============================================================================
# Find & Replace Dialog  (Section 26 — custom Toplevel)
# =============================================================================
sub cmd_find {
    # Only open one Find dialog at a time
    if (Exists($mw) && grep { ref($_) eq "Tk::Toplevel" && $_->title eq "Find / Replace" }
                            $mw->children) {
        return;
    }

    my $dlg = $mw->Toplevel;
    $dlg->title("Find / Replace");
    $dlg->geometry("380x180+200+150");
    $dlg->transient($mw);           # Keep above main window
    $dlg->configure(-background => "#f2f2f7");
    $dlg->resizable(0, 0);

    my ($find_text, $replace_text) = ("", "");
    my $case_sensitive = 0;
    my $find_result    = "";

    # Grid layout for the form
    $dlg->gridColumnconfigure(1, -weight => 1);

    $dlg->Label(-text => "Find:", -background => "#f2f2f7",
                -font => "Helvetica 11")->grid(-row => 0, -column => 0, -sticky => "e", -padx => 5, -pady => 5);
    my $find_entry = $dlg->Entry(-textvariable => \$find_text, -width => 25,
                                  -font => "Helvetica 11"
                                 )->grid(-row => 0, -column => 1, -sticky => "ew", -padx => 5, -pady => 5);

    $dlg->Label(-text => "Replace:", -background => "#f2f2f7",
                -font => "Helvetica 11")->grid(-row => 1, -column => 0, -sticky => "e", -padx => 5, -pady => 5);
    $dlg->Entry(-textvariable => \$replace_text, -width => 25,
                -font => "Helvetica 11"
               )->grid(-row => 1, -column => 1, -sticky => "ew", -padx => 5, -pady => 5);

    $dlg->Checkbutton(-text => "Case sensitive", -variable => \$case_sensitive,
                       -background => "#f2f2f7", -font => "Helvetica 10"
                      )->grid(-row => 2, -column => 1, -sticky => "w", -padx => 5);

    my $result_lbl = $dlg->Label(-textvariable => \$find_result,
                                  -font => "Helvetica 10 italic",
                                  -foreground => "#555555",
                                  -background => "#f2f2f7",
                                 )->grid(-row => 3, -column => 0, -columnspan => 2);

    # Button row
    my $btn_row = $dlg->Frame(-background => "#f2f2f7")->grid(
        -row => 4, -column => 0, -columnspan => 2, -pady => 8
    );

    $btn_row->Button(-text => "Find Next", -font => "Helvetica 10",
                     -padx => 8, -pady => 3,
                     -command => sub {
                         $find_result = do_find($find_text, $case_sensitive);
                     })->pack(-side => "left", -padx => 4);

    $btn_row->Button(-text => "Replace", -font => "Helvetica 10",
                     -padx => 8, -pady => 3,
                     -command => sub {
                         $find_result = do_replace($find_text, $replace_text, $case_sensitive, 0);
                     })->pack(-side => "left", -padx => 4);

    $btn_row->Button(-text => "Replace All", -font => "Helvetica 10",
                     -padx => 8, -pady => 3,
                     -command => sub {
                         $find_result = do_replace($find_text, $replace_text, $case_sensitive, 1);
                     })->pack(-side => "left", -padx => 4);

    $btn_row->Button(-text => "Close", -font => "Helvetica 10",
                     -padx => 8, -pady => 3,
                     -command => sub { $dlg->destroy })->pack(-side => "left", -padx => 4);

    $find_entry->focus;
    $find_entry->bind("<Return>", sub { $find_result = do_find($find_text, $case_sensitive) });
}

sub do_find {
    my ($pattern, $case) = @_;
    return "Nothing to find." unless $pattern;

    # Remove previous highlight
    $editor->tagRemove("found", "1.0", "end");
    $editor->tagConfigure("found", -background => "#ffffa0", -foreground => "#000000");

    my $mod = $case ? "" : "i";
    my $pos = $editor->index("insert");
    my $idx = eval { $editor->search("-regexp", ($case ? () : "-nocase"), "--",
                                      $pattern, $pos, "end") };
    unless ($idx) {
        # Wrap around
        $idx = eval { $editor->search("-regexp", ($case ? () : "-nocase"), "--",
                                       $pattern, "1.0", "end") };
    }
    return "Not found: $pattern" unless $idx;

    my $end_idx = $editor->index("$idx + " . length($pattern) . " chars");
    $editor->tagAdd("found", $idx, $end_idx);
    $editor->see($idx);
    $editor->mark("set", "insert", $end_idx);
    return "Found at $idx";
}

sub do_replace {
    my ($find, $replace, $case, $all) = @_;
    return "Nothing to find." unless $find;

    $editor->tagRemove("found", "1.0", "end");
    my $count = 0;
    my $start = "1.0";

    while (1) {
        my $idx = eval { $editor->search("-regexp", ($case ? () : "-nocase"), "--",
                                          $find, $start, "end") };
        last unless $idx;
        my $end = $editor->index("$idx + " . length($find) . " chars");
        $editor->delete($idx, $end);
        $editor->insert($idx, $replace);
        $count++;
        $start = "$idx + " . length($replace) . " chars";
        last unless $all;
    }

    return $count ? "Replaced $count occurrence(s)." : "Not found: $find";
}

# =============================================================================
# View Operations
# =============================================================================
sub apply_wrap {
    $editor->configure(-wrap => ($word_wrap ? "word" : "none"));
}

sub toggle_line_numbers {
    if ($show_line_nums) {
        $line_num_text->pack(-side => "left", -fill => "y", -before => $editor);
    } else {
        $line_num_text->packForget;
    }
}

sub change_font {
    my ($delta) = @_;
    $font_size = $font_size + $delta;
    $font_size = 8  if $font_size < 8;
    $font_size = 36 if $font_size > 36;
    apply_font();
}

sub apply_font {
    my $font = "Courier $font_size";
    $editor->configure(-font => $font);
    $line_num_text->configure(-font => $font);
    update_line_numbers();
}

# =============================================================================
# Live Status Updates  (after() timer, Section 25)
# =============================================================================
sub update_status_loop {
    # Update line/col display
    my $pos = $editor->index("insert");   # Format: "line.column"
    if ($pos =~ /^(\d+)\.(\d+)$/) {
        $line_col_msg = sprintf("Ln %d, Col %d", $1, $2 + 1);
    }

    # Word count
    my $text_content = $editor->get("1.0", "end");
    my @wds = ($text_content =~ /\S+/g);
    $word_count = scalar(@wds) . " words";

    update_line_numbers();

    # Re-schedule
    $mw->after(500, \&update_status_loop);
}

sub update_line_numbers {
    return unless $show_line_nums;
    my $last_line = $editor->index("end - 1 chars");
    $last_line =~ s/\..*//;   # Extract line number

    $line_num_text->configure(-state => "normal");
    $line_num_text->delete("1.0", "end");
    for my $n (1 .. $last_line) {
        $line_num_text->insert("end", sprintf("%4d\n", $n));
    }
    $line_num_text->configure(-state => "disabled");
    $line_num_text->yview("moveto", ($editor->yview)[0]);  # Sync scroll
}

# =============================================================================
# Modification Tracking
# =============================================================================
sub on_text_modified {
    if ($editor->edit_modified) {
        $modified = 1;
        my $title = $current_file // "New Document";
        $mw->title("PerlPad — * $title");
        $status_msg = "Modified";
    }
}

sub on_key_release {
    $modified = 1 if $editor->edit_modified;
}

# =============================================================================
# Help Dialogs
# =============================================================================
sub show_about {
    $mw->messageBox(
        -title   => "About PerlPad",
        -message => "PerlPad\nA Perl/Tk Text Editor\n\n"
                  . "Demonstrates a complete Perl/Tk application:\n"
                  . "  • Menus, toolbars, dialogs\n"
                  . "  • File I/O with dirty state tracking\n"
                  . "  • Find & Replace with regex\n"
                  . "  • Live status bar updates\n"
                  . "  • macOS keyboard shortcuts\n\n"
                  . "From: The Comprehensive Perl GUI Guide",
        -type    => "OK",
        -icon    => "info",
    );
}

sub show_shortcuts {
    $mw->messageBox(
        -title   => "Keyboard Shortcuts",
        -message => "Cmd+N     New document\n"
                  . "Cmd+O     Open file\n"
                  . "Cmd+S     Save\n"
                  . "Cmd+Shift+S  Save As\n"
                  . "Cmd+Z     Undo\n"
                  . "Cmd+X/C/V  Cut / Copy / Paste\n"
                  . "Cmd+A     Select All\n"
                  . "Cmd+F     Find / Replace\n"
                  . "Cmd++     Increase font size\n"
                  . "Cmd+-     Decrease font size\n"
                  . "Cmd+Q/W   Quit",
        -type    => "OK",
        -icon    => "info",
    );
}

# =============================================================================
# Welcome Text
# =============================================================================
sub welcome_text { return <<'END_WELCOME';
Welcome to PerlPad!
===================

This is a fully-featured text editor written entirely in Perl
using the Perl/Tk GUI toolkit.

Features demonstrated in this application:
  - Complete menu bar (File, Edit, View, Help)
  - File open / save / save-as with dirty tracking
  - Find & Replace with regex support
  - Keyboard shortcuts (macOS Cmd key)
  - Live status bar (line, column, word count)
  - Word wrap toggle
  - Font size control
  - Line number sidebar
  - Window close intercept for unsaved changes

Try the menu items, keyboard shortcuts, and the Find dialog!
(Cmd+F to open Find / Replace)

This is the final tutorial in the Perl GUI series.
See perl_mac_guide.md for the full guide.
END_WELCOME
}