#!perl -w
#
# T-Pad - A Perl/Tk GUI based Perl-script editor with syntax highlighting
#
# Usage: see Perl documentation in pod format (perldoc)
#
use strict;
use Tk;

{   ###########################################################################
    package TextHighlight;
    ###########################################################################

    use vars qw($VERSION %FUNC %FLOW %OPER);
    $VERSION = '4.04';

    my @FUNC = qw/AUTOLOAD BEGIN CHECK CORE DESTROY END INIT abs accept alarm atan2 bind binmode bless caller chdir chmod chomp chop chown chr chroot close closedir cmp connect cos crypt dbmclose dbmopen defined delete die dump each endgrent endhostent endnetent endprotoent endpwent endservent eof eval exec exists exit exp fcntl fileno flock fork format formline getc getgrent getgrgid getgrnam gethostbyaddr gethostbyname gethostent getlogin getnetbyaddr getnetbyname getnetent getpeername getpgrp getppid getpriority getprotobyname getprotobynumber getprotoent getpwent getpwnam getpwuid getservbyname getservbyport getservent getsockname getsockopt glob gmtime grep hex index int ioctl join keys kill lc lcfirst length link listen localtime log lock lstat map mkdir msgctl msgget msgrcv msgsnd new oct open opendir ord pack pipe pop pos print printf prototype push quotemeta rand read readdir readline readlink readpipe recv ref rename reset reverse rewinddir rindex rmdir scalar seek seekdir select semctl semget semop send setgrent sethostent setnetent setpgrp setpriority setprotoent setpwent setservent setsockopt shift shmctl shmget shmread shmwrite shutdown sin sleep socket socketpair sort splice split sprintf sqrt srand stat study substr symlink syscall sysopen sysread sysseek system syswrite tell telldir tie tied time times truncate uc ucfirst umask undef unlink unpack unshift untie utime values vec wait waitpid wantarray warn write/;
    my @FLOW = qw/continue do else elsif for foreach goto if last local my next our no package redo require return sub unless until use while __DATA__ __END__ __FILE__ __LINE__ __PACKAGE__/;
    my @OPER = qw/and eq ge gt le lt m ne not or q qq qr qw qx s tr y xor x/;

    # Build lookup tables
    @FUNC{@FUNC} = (1) x @FUNC; undef @FUNC;
    @FLOW{@FLOW} = (1) x @FLOW; undef @FLOW;
    @OPER{@OPER} = (1) x @OPER; undef @OPER;

    use Tk qw(Ev);
    use AutoLoader;

    # Set @TextHighlight::ISA = ('Tk::TextUndo')
    use base qw(Tk::TextUndo);

    Construct Tk::Widget 'TextHighlight';

    sub ClassInit {
        my ($class, $mw) = @_;
        $class->SUPER::ClassInit($mw);
        $mw->bind($class, '<Control-o>', \&main::openDialog);
        $mw->bind($class, '<Control-n>', [\&main::addPage, 'Untitled']);
        $mw->bind($class, '<Control-s>', [\&main::saveDialog, 's']);
        $mw->bind($class, '<Control-r>', \&main::runScript);
        $mw->bind($class, '<F1>', \&main::commandHelp);
        return $class;
    }

    sub InitObject {
        my ($w, $args) = @_;
        $w->SUPER::InitObject($args);
        $w->tagConfigure('FUNC', -foreground => '#FF0000');
        $w->tagConfigure('FLOW', -foreground => '#0000FF');
        $w->tagConfigure('OPER', -foreground => '#FF8200');
        $w->tagConfigure('STRG', -foreground => '#848284');
        $w->tagConfigure('CMNT', -foreground => '#008284');
        $w->tagConfigure('MTCH', -background => '#FFFF00');
        # Default: font family courier, size 10
        $w->configure(-font => $w->fontCreate(qw/-family courier -size 10/));
        $w->{CALLBACK} = undef;
        $w->{CHANGES} = 0;
        $w->{LINE} = 0;
    }

    sub Button1 {
        my $w = shift;
        $w->SUPER::Button1(@_);
        &{$w->{CALLBACK}} if ( defined $w->{CALLBACK} );
    }

    sub see {
        my $w = shift;
        $w->SUPER::see(@_);
        &{$w->{CALLBACK}} if ( defined $w->{CALLBACK} );
    }

    # Set/Get the amount of changes
    sub numberChangesExt {
        my ($w, $changes) = @_;
        if ( @_ > 1 ) {
            $w->{CHANGES} = $changes;
        }
        return $w->{CHANGES};
    }

    # Register callback function and call it immediately
    sub positionChangedCallback {
        my ($w, $callback) = @_;
        &{$w->{CALLBACK} = $callback};
    }

    sub insert {
        my $w = shift;
        my ($s_line) = split(/\./, $w->index('insert'));
        $w->SUPER::insert(@_);
        my ($e_line) = split(/\./, $w->index('insert'));
        highlight($w, $s_line, $e_line);
        &{$w->{CALLBACK}} if ( defined $w->{CALLBACK} );
    }

    # Insert text without highlight
    sub insertWHL {
        my $w = shift;
        $w->SUPER::insert(@_);
    }

    # Background highlight
    sub backgroundHL {
        my ($w, $l) = @_;
        my ($end) = split(/\./, $w->index('end'));
        $w->{LINE} = $end unless ( $w->{LINE} );
        # 'cut/delete' correction if needed
        if ( $w->{LINE} != $end ) {
            $l -= ($w->{LINE} - $end);
            if ( $l < 0 ) { $l = 0 }
            $w->{LINE} = $end;
        }
        highlight($w, $l, $l+50 > $end ? $end-1 : $l+50);
        if ( $l+50 < $end ) {
            $w->after(50, [\&backgroundHL, $w, $l+50+1]);
        }
        else { $w->{LINE} = 0 }
    }

    sub insertTab {
        my ($w) = @_;
        my $pos = (split(/\./, $w->index('insert')))[1];
        # Insert spaces instead of tabs
        $w->Insert(' ' x (4-($pos%4)));
        $w->focus;
        &{$w->{CALLBACK}} if ( defined $w->{CALLBACK} );
        $w->break;
    }

    sub delete {
        my $w = shift;
        $w->SUPER::delete(@_);
        my ($line) = split(/\./, $w->index('insert'));
        highlight($w, $line, $line);
    }

    sub InsertKeypress {
        my $w = shift;
        $w->SUPER::InsertKeypress(@_);

        # Easy things easy...
        if ( $_[0] =~ /[([{<"']/ ) {
            $w->SUPER::InsertKeypress(')') if ( $_[0] eq '(' );
            $w->SUPER::InsertKeypress(']') if ( $_[0] eq '[' );
            $w->SUPER::InsertKeypress('}') if ( $_[0] eq '{' );
            $w->SUPER::InsertKeypress('>') if ( $_[0] eq '<' );
            $w->SUPER::InsertKeypress('"') if ( $_[0] eq '"' );
            $w->SUPER::InsertKeypress("'") if ( $_[0] eq "'" );
            $w->SetCursor('insert-1c');
        }

        my ($line) = split(/\./, $w->index('insert'));
        highlight($w, $line, $line);
        &{$w->{CALLBACK}} if ( defined $w->{CALLBACK} );
    }

    sub highlight {
        my ($w, $s_line, $e_line) = @_;

        # Remove tags from current area
        foreach ( qw/FUNC FLOW OPER STRG CMNT/ ) {
            $w->tagRemove($_, $s_line.'.0', $e_line.'.end');
        }

        foreach my $ln($s_line .. $e_line) {
            my $line = $w->get($ln.'.0', $ln.'.end');
            # Highlight: strings
            while ( $line =~ /("             # Start at double quote
                                  (?:        # For grouping only
                                      \\.|   # Backslash with any character
                                      [^"\\] # Must not be able to find
                                  )*         # Zero or more sets of those
                              "|
                              (?<!\$)        # Prevent $' match
                              '              # Start at single quote
                                  (?:        # For grouping only
                                      \\.|   # Backslash with any character
                                      [^'\\] # Must not be able to find
                                  )*         # Zero or more sets of those
                              ')/gx ) {
                $w->tagAdd('STRG', $ln.'.'.(pos($line)-length($1)),
                           $ln.'.'.pos($line));
            }
            # Highlight: comments
            while ( $line =~ /(?<!       # Lookbehind for neither
                                  [\$\\] # $ nor \
                              )\#        # Start of the comment
                             /gx ) {
                next if ( $w->tagNames($ln.'.'.(pos($line)-1)) &&
                          $w->tagNames($ln.'.'.(pos($line)-1)) eq 'STRG' );
                $w->tagAdd('CMNT', $ln.'.'.(pos($line)-1), $ln.'.end');
                $line = $w->get($ln.'.0', $ln.'.'.(pos($line)-1));
                last;
            }
            # Highlight: functions, flow control words and operators,
            # do not highlight hashes, arrays or scalars
            while ( $line =~ /(?<!              # Lookbehind for neither
                                  [\%\@\$])     # %, @, nor $
                                      \b        # Match a word boundary
                                          (\w+) # Match a "word"
                                      \b        # Match a word boundary
                             /gx ) {
                if ( $OPER{$1} ) {
                    $w->tagAdd('OPER', $ln.'.'.(pos($line)-length($1)),
                               $ln.'.'.pos($line));
                }
                elsif ( $FLOW{$1} ) {
                    $w->tagAdd('FLOW', $ln.'.'.(pos($line)-length($1)),
                               $ln.'.'.pos($line));
                }
                elsif ( $FUNC{$1} || $1 =~ /^(\d+)$/ ) {
                    $w->tagAdd('FUNC', $ln.'.'.(pos($line)-length($1)),
                               $ln.'.'.pos($line));
                }
            }
        }
    }
} # END - package TextHighlight

###############################################################################
package main;
###############################################################################

use File::Find;
use File::Basename;
use Tk::HList;
use Tk::Dialog;
use Tk::ROText;
use Tk::Balloon;
use Tk::DropSite;
use Tk::NoteBook;
use Tk::Adjuster;

# Seed the random number generator
BEGIN { srand() if $] < 5.004 }

# List of supported file patterns
my @filetypes = (
    ['Perl Scripts',     '.pl',  'TEXT'],
    ['Perl Modules',     '.pm',  'TEXT'],
    ['Perl CGI Scripts', '.cgi', 'TEXT']);

# Create main window and return window handle
my $mw = MainWindow->new(-title => 'T-Pad');

# Manage window manager protocol
$mw->protocol('WM_DELETE_WINDOW' => \&exitCommand);

# Add menubar
$mw->configure(-menu =>
my $menubar = $mw->Menu(-tearoff => $Tk::platform eq 'unix'));

# Add 'File' entry to the menu
my $file = $menubar->cascade(qw/-label File -underline 0 -menuitems/ =>
    [
        [command => '~New',         -accelerator => 'Ctrl+N',
                                    -command => [\&addPage, 'Untitled']],
        [command => '~Open...',     -accelerator => 'Ctrl+O',
                                    -command => \&openDialog],
        [command => '~Close',       -command => \&closeCommand,
                                    -state   => 'disabled'],
        '',
        [command => '~Save',        -accelerator => 'Ctrl+S',
                                    -command => [\&saveDialog, 's']],
        [command => 'Save ~As...',  -command => [\&saveDialog, 'a']],
        '',
        [command => 'E~xit',        -command => \&exitCommand],
    ], -tearoff => $Tk::platform eq 'unix');

# Add 'Edit' entry to the menu
my $edit = $menubar->cascade(qw/-label Edit -underline 0 -menuitems/ =>
    [
        [command => '~Undo',        -accelerator => 'Ctrl+Z',
                                    -command => [\&menuCommands, 'eu']],
        [command => '~Redo',        -accelerator => 'Ctrl+Y',
                                    -command => [\&menuCommands, 'er']],
        '',
        [command => 'Cu~t',         -accelerator => 'Ctrl+X',
                                    -command => [\&menuCommands, 'et']],
        [command => 'C~opy',        -accelerator => 'Ctrl+C',
                                    -command => [\&menuCommands, 'eo']],
        [command => 'P~aste',       -accelerator => 'Ctrl+V',
                                    -command => [\&menuCommands, 'ea']],
        '',
        [command => 'Select A~ll',  -command => [\&menuCommands, 'el']],
        [command => 'Unsele~ct All',-command => [\&menuCommands, 'ec']],
    ], -tearoff => $Tk::platform eq 'unix');

# Add 'Misc' entry to the menu
my $misc = $menubar->cascade(qw/-label Misc -underline 0 -menuitems/ =>
    [
        [command => '~Properties...',       -command => \&propertiesDialog],
        [Checkbutton => 'CR~LF Conversion', -variable => \my $crlf],
        [command => "Script's PO~D...",     -command => \&perlDoc],
        [command => '~Run',                 -accelerator => 'Ctrl+R',
                                            -command => \&runScript],
    ], -tearoff => $Tk::platform eq 'unix');

# Add 'Help' entry to the menu
my $help = $menubar->cascade(qw/-label Help -underline 0 -menuitems/ =>
    [
        [command => '~Commands...', -accelerator => 'F1',
                                    -command => \&commandHelp],
        [command => '~About...',    -command => \&aboutDialog],
    ], -tearoff => $Tk::platform eq 'unix');

# Add NoteBook metaphor
my $nb = $mw->NoteBook();

# Accept drops from an external application
$nb->DropSite(-dropcommand => \&handleDND,
              -droptypes   => ($^O eq 'MSWin32' or ($^O eq 'cygwin' and
                              $Tk::platform eq 'MSWin32')) ? ['Win32'] :
                              [qw/KDE XDND Sun/]);

my ($tw, $cmdHelp, %pageName);
# Accept ASCII text file or file which does not exist
foreach ( @ARGV ) {
    if ( (-e $_ && -T _) || !-e _ ) {
        addPage($_);
    }
}

# Add default page if there are no pages in notebook metaphor
unless ( keys %pageName ) {
    addPage('Untitled');
}

# Show filename over the 'pageName' using balloons
my ($balloon, $msg) = $mw->Balloon(-state => 'balloon',
                                   -balloonposition => 'mouse');
$balloon->attach($nb, -balloonmsg => \$msg,
                -motioncommand => sub {
                    my ($nb, $x, $y) = @_;
                    # Adjust screen to widget coordinates
                    $x -= $nb->rootx;
                    $y -= $nb->rooty;
                    my $name = $nb->identify($x, $y);
                    if ( defined $name ) {
                        $msg = 'File name: '.$pageName{$name}->FileName();
                        0; # Don't cancel the balloon
                    } else { 1 } # Cancel the balloon
                });

# Add status bar to the bottom of the screen
my $fr = $mw->Frame->pack(qw/-side bottom -fill x/);
$fr->Label(-textvariable => \my $st)->pack(qw/-side left/);
$fr->Label(-textvariable => \my $clk)->pack(qw/-side right/);
updateClock();

# Create Text widget where the user can type commands
my $cw = $mw->Scrolled(qw/Text
                          -spacing2 1 -spacing3 1
                          -scrollbars e -height 3
                          -background white
                          -relief ridge/)->pack(qw/-side bottom
                                                   -fill x -padx 1/);

# Miscellaneous configurations to the command window
$cw->configure(-font => $tw->cget(-font));
$cw->menu(undef);
$cw->tagConfigure('FILE', -foreground => '#0000FF');
$cw->tagBind('FILE', '<Any-Enter>' => sub {
    shift->configure(qw/-cursor hand2/);
});
$cw->tagBind('FILE', '<Any-Leave>' => sub {
    shift->configure(qw/-cursor xterm/);
});
$cw->tagBind('FILE', '<ButtonRelease-1>' => sub {
    my $text = shift;
    my ($l) = split(/\./, $text->index('current'));
    my $txt = $text->get($l.'.0', "$l.end");
    if ( $txt =~ /^(.*?)\((\d+)\)/ ) {
        addPage($1);
        gotoLine($2);
    }
});
mouseWheel($cw);

my $prev_cmd;
$mw->Adjuster->packAfter($cw, -side => 'bottom');
$nb->pack(qw/-side top -expand 1 -fill both/);

# Arrange for X events to invoke callbacks
$cw->bind('<Return>', \&executeCommand);
$cw->bind('<Escape>', sub { $tw->focus });
$cw->bind('<F1>', \&commandHelp);

# Start the GUI and eventloop
MainLoop;

# Create modal 'About' dialog
sub aboutDialog {
    my $popup = $mw->Dialog(
        -popover        => $mw,
        -title          => 'About T-Pad',
        -bitmap         => 'Tk',
        -default_button => 'OK',
        -buttons        => ['OK'],
        -text           => "T-Pad\nVersion 4.04 - 05-Aug-2003\n\n".
                           "Copyright (C) Tomi Parviainen\n".
                           "http://www.cpan.org/scripts/\n\n".
                           "Perl Version $]\n".
                           "Tk Version $Tk::VERSION",
        );
    $popup->resizable('no', 'no');
    $popup->Show();
}

# Add page to notebook metaphor
sub addPage {
    shift if UNIVERSAL::isa($_[0], 'TextHighlight');
    my $pageName = shift;

    # If the page exist, raise the old page and return
    foreach ( keys %pageName ) {
        if ( ($pageName{$_})->FileName() eq $pageName &&
              $pageName ne 'Untitled' ) {
            return $nb->raise($_);
        }
    }

    # Add new page with 'random' name to the notebook
    my $name = rand();
    my $page = $nb->add($name,
                        -label => basename($pageName),
                        -raisecmd => \&pageChanged);

    # Create a widget with attached scrollbar(s)
    $tw = $page->Scrolled(qw/TextHighlight
                            -spacing2 1 -spacing3 1
                            -scrollbars ose -background white
                            -borderwidth 2 -width 80 -height 25
                            -relief sunken/)->pack(qw/-expand 1 -fill both/);

    $tw->FileName($pageName);
    $pageName{$name} = $tw;
    $tw->bind('<FocusIn>', sub {
        $tw->tagRemove('MTCH', '0.0', 'end');
    });

    # Change popup menu to contain 'Edit' menu entry
    $tw->menu($edit->menu);
    mouseWheel($tw);

    if ( keys %pageName > 1 ) {
        # Enable 'File->Close' menu entry
        $file->cget(-menu)->entryconfigure(2 + ($Tk::platform eq 'unix'),
                                           -state => 'normal');
    }

    $nb->raise($name);

    # Write data to the new page. File 'Untitled' can
    # be used as a template for new script files!
    writeData($pageName);

    # Register callback function
    $tw->positionChangedCallback(\&updateStatus);
}

# Remove page and disable 'Close' menu item when needed
sub closeCommand {
    if ( confirmCh() ) {
        delete $pageName{$nb->raised()};
        $nb->delete($nb->raised());
    }
    if ( keys %pageName == 1 ) {
        # Disable 'File->Close' menu entry
        $file->cget(-menu)->entryconfigure(2 + ($Tk::platform eq 'unix'),
                                           -state => 'disabled');
    }
}

# Confirm the changes user has made before proceeding
sub confirmCh {
    if ( $nb->pagecget($nb->raised(), -label) =~ /\*/ ) {
        my $answer = $tw->Dialog(
                        -popover => $mw, -text => 'Save changes to '.
                         basename($tw->FileName()), -bitmap => 'warning',
                        -title => 'T-Pad', -default_button => 'Yes',
                        -buttons => [qw/Yes No Cancel/])->Show;
        if ( $answer eq 'Yes' ) {
            saveDialog('s');
            return 0 if ( $nb->pagecget($nb->raised(), -label) =~ /\*/ ||
                          $tw->FileName() eq 'Untitled' );
        }
        elsif ( $answer eq 'Cancel' ) {
            return 0;
        }
    }
    return 1;
}

# Create Hierarchical List widget, which shows supported commands
# and a short description of each command
sub commandHelp {
    if ( defined $cmdHelp ) {
        $cmdHelp->focus;
        return;
    }
    $cmdHelp = $mw->Toplevel(-title => 'T-Pad Commands [Ctrl+Tab, ESC]');
    my $hl = $cmdHelp->Scrolled('HList', -header => 1, -columns => 2,
                                -scrollbars => 'osoe', -width => 70,
                                -height => 31)
                                ->pack(qw/-expand 1 -fill both/);

    my %commands = (
        'a' => 'About T-Pad',
        'c' => 'Close an opened script file',
        'doc x' => 'Look up Perl documentation for built in function \'x\'',
        'eval x' => 'Evaluate expression \'x\'',
        'f x' => 'Find the specified pattern \'x\'',
        'fb x' => 'Find the specified pattern \'x\', proceed backward',
        'fc x' => 'Find the specified pattern \'x\', use match case',
        'ff o t x' => 'Find the specified pattern \'x\' from folder o, file'.
                      ' types t,'."\n".'Example: ff c:\perl\bin *.pl;*.pm Tk',
        'fr x' => 'Find the specified pattern \'x\', use regular expression',
        'g x' => 'Goto a specified line \'x\'',
        'n' => 'Create a new script file',
        'o' => 'Open an existing script file',
        'p' => 'File properties',
        'r [a]' => 'Run the active script, [with arguments a]',
        's' => 'Save the active script using the same filename',
        'sa' => 'Save the active script as a new file',
        'wc' => 'Change the wrap mode to \'char\'',
        'wn' => 'Change the wrap mode to \'none\'',
        'ww' => 'Change the wrap mode to \'word\'',
        'x' => 'Exit');

    my $position = 0;
    $hl->header('create', 0, -text => 'Command');
    $hl->header('create', 1, -text => 'Description');
    foreach ( sort keys %commands ) {
        $hl->add($position, -state => 'disabled');
        $hl->itemCreate($position,   0, -text => $_);
        $hl->itemCreate($position++, 1, -text => $commands{$_});
    }
    $cmdHelp->focus;
    $cmdHelp->protocol('WM_DELETE_WINDOW' => sub {
        $cmdHelp->withdraw;
        undef $cmdHelp;
    });
}

# Execute command given by the user
sub executeCommand {
    my ($ln, $col) = split(/\./, $cw->index('insert'));
    if ( ($_ = $cw->get(--$ln.'.0', "$ln.end")) eq '' ) {
        # Repeat previous command
        $_ = $prev_cmd ? $prev_cmd : '';
        $cw->delete($ln--.'.0', 'end');
        $cw->insert('end', "\n$_\n");
    }
    else { $prev_cmd = $_ }

    if ( /^a$/ )    { aboutDialog() }
    elsif ( /^c$/ ) {
        if ( keys %pageName > 1 ) {
            closeCommand();
        }
    }
    elsif ( /^doc\s+(.+)$/ ) {
        my $doc = `perldoc -t -f $1`;
        unless ( $doc ) {
            $doc = "No documentation for perl function `$1' found";
        }
        $doc =~ s/\n+$//;
        $cw->insert('end', "$doc\n");
    }
    elsif ( /^eval\s+(.+)$/ ) {
        eval {
            my $r = eval $1;
            $cw->insert('end', ($r ? $r : 'undef')."\n");
        };
    }
    elsif ( /^f(.*?)\s+(.+)$/ ) {
        my ($cm, $da, $no, %sw) = ($1, $2, 0);
        if ( $cm =~ /c/ ) { $sw{-exact} = 1 }
        else              { $sw{-nocase} = 1 }
        if ( $cm =~ /r/ ) { $sw{-regexp} = 1 }
        if ( $cm =~ /b/ ) { $sw{-backwards} = 1 }
        if ( $tw->tagRanges('MTCH') ) {
            if ( $sw{-backwards} ) {
                $tw->markSet('insert', ($tw->tagRanges('MTCH'))[0]);
            }
            else {
                $tw->markSet('insert', ($tw->tagRanges('MTCH'))[1]);
            }
            $tw->tagRemove('MTCH', '0.0', 'end');
        }
        if ( $cm =~ /f/ ) {
            findFiles($da);
            return;
        }
        my $match = $tw->search(keys %sw, -count => \$no, '--',
                                $da, $tw->index('insert'));
        if ( $match ) {
            $tw->tagAdd('MTCH', $match, "$match + $no char");
            $tw->markSet('insert', "$match  + $no char");
            $tw->see('insert');
            $tw->markUnset('insert');
        }
        else {
            # Didn't match, ring the bell
            $mw->bell;
        }
    }
    elsif ( /^g\s*(\d+)$/ )  { gotoLine($1) }
    elsif ( /^n$/ )          { addPage('Untitled') }
    elsif ( /^o$/ )          { openDialog() }
    elsif ( /^p$/ )          { propertiesDialog() }
    elsif ( /^r\s*(.*)$/ )   { runScript($1) }
    elsif ( /^s$/ )          { saveDialog('s') }
    elsif ( /^sa$/ )         { saveDialog('a') }
    elsif ( /^w([ncw])$/ )   {
        my $wm = $1; # Wrap mode
        if ( $wm eq 'n' )    { $wm = 'none' }
        elsif ( $wm eq 'c' ) { $wm = 'char' }
        else                 { $wm = 'word' }
        $tw->configure(-wrap => $wm);
    }
    elsif ( /^x$/ )          { exitCommand() }
    else                     { $cw->insert('end', "->[ERROR]\n") }

    $cw->SetCursor('end-1char');
}

# Close all pages and quit T-Pad
sub exitCommand {
    while ( (my $pages = keys %pageName) > 0 ) {
        closeCommand();
        # Check if the user has pressed 'Cancel' button
        last if ( keys %pageName == $pages );
    }
    exit if ( keys %pageName == 0 );
}

# Find '$data' pattern from files, scan recursively
sub findFiles {
    my ($path, $ext, $data) = split(/ /, shift);
    return unless ( defined $data );
    my ($dir, %files);

    find(sub {
        return if ( !-f || !-T || !defined $mw->focusCurrent ||
                    UNIVERSAL::isa($mw->focusCurrent, 'TextHighlight') );
        my $filename = $_;
        if ( !$dir || $dir ne $File::Find::dir ) {
            $cw->update;
            $dir = $File::Find::dir;
            undef %files;
            foreach ( split(/;/, $ext) ) {
                foreach ( glob("$_") ) {
                    $files{$_} = 1;
                }
            }
        }

        if ( $files{$filename} && open(FILE, $filename) ) {
            while ( my $line = <FILE> ) {
                next unless ( $line =~ /\Q$data\E/i );
                chomp($line);
                $cw->insert('end', "$File::Find::name", 'FILE');
                $cw->insert('end', "($.):$line\n");
                $cw->SetCursor('end-1char');
                $cw->update;
            }
            close(FILE) or warn "$!";
        }
    }, $path);
}

# Goto line, which has been passed as a parameter
sub gotoLine {
    my $line = shift;
    $tw->markSet('insert', "$line.0");
    $tw->see('insert');
    $tw->markUnset('insert');
    $tw->tagRemove('MTCH', '0.0', 'end');
    $tw->tagAdd('MTCH', "$line.0", "$line.0 lineend + 1c");
}

# Get the filename of the drop and add new page to the notebook metaphor
sub handleDND {
    my ($sel, $filename) = shift;

    # In case of an error, do the SelectionGet in an eval block
    eval {
        if ( $^O eq 'MSWin32' ) {
            $filename = $tw->SelectionGet(-selection => $sel, 'STRING');
        }
        else {
            $filename = $tw->SelectionGet(-selection => $sel, 'FILE_NAME');
        }
    };
    if ( defined $filename && -T $filename ) {
        addPage($filename);
    }
}

# Handle different menu accelerator commands, which cannot be handled
# directly in menu entry (because of the tight bind of $tw)
sub menuCommands {
    my $cmd = shift;
    if    ( $cmd eq 'eu' ) { $tw->undo }
    elsif ( $cmd eq 'er' ) { $tw->redo }
    elsif ( $cmd eq 'et' ) { $tw->clipboardCut }
    elsif ( $cmd eq 'eo' ) { $tw->clipboardCopy }
    elsif ( $cmd eq 'ea' ) { $tw->clipboardPaste }
    elsif ( $cmd eq 'el' ) { $tw->selectAll }
    elsif ( $cmd eq 'ec' ) { $tw->unselectAll }
}

# Support for mouse wheel
sub mouseWheel {
    my $w = shift;

    # Windows support
    $w->bind('<MouseWheel>', [sub {
        $_[0]->yviewScroll(-($_[1]/120)*3, 'units');
    }, Tk::Ev('D')]);

    # UNIX support
    if ( $Tk::platform eq 'unix' ) {
        $w->bind('<4>', sub {
            $_[0]->yviewScroll(-3, 'units') unless $Tk::strictMotif;
        });
        $w->bind('<5>', sub {
            $_[0]->yviewScroll( 3, 'units') unless $Tk::strictMotif;
        });
    }
}

# Pop up a dialog box for the user to select a file to open
sub openDialog {
    my $filename = $mw->getOpenFile(-filetypes => \@filetypes);
    if ( defined $filename and $filename ne '' ) {
        addPage($filename)
    }
}

# Notebook page has changed, change the focus to the new page
# and initialise status bar to reflect page data
sub pageChanged {
    $tw = $pageName{$nb->raised()};
    $tw->focus if ( !defined $mw->focusCurrent ||
                    UNIVERSAL::isa($mw->focusCurrent, 'MainWindow') ||
                    UNIVERSAL::isa($mw->focusCurrent, 'TextHighlight') );

    # Disable/Enable 'Misc->Properties' menu entry
    if ( -e $tw->FileName() ) {
        $misc->cget(-menu)->entryconfigure(0 + ($Tk::platform eq 'unix'),
                                           -state => 'active');
    }
    else {
        $misc->cget(-menu)->entryconfigure(0 + ($Tk::platform eq 'unix'),
                                           -state => 'disabled');
    }
    updateStatus();
}

# Look up Perl documentation in pod format
sub perlDoc {
    my $fileName = $tw->FileName();
    my $doc = `perldoc -t \"$fileName\"`;
    unless ( $doc ) {
        $doc = "No documentation found for \"$fileName\".\n";
    }
    my $tl = $mw->Toplevel(-title => "Perl Documentation in POD Format [".
                          (basename($tw->FileName()))."]");
    my $pod = $tl->Scrolled(qw/ROText -scrollbars oe -width 80 -height 25
                               -spacing2 1 -spacing3 1/);
    mouseWheel($pod);
    $pod->menu(undef);
    $pod->configure(-font => $tw->cget(-font));
    $pod->pack(qw/-expand 1 -fill both/);
    $pod->insert('1.0', $doc);
    $pod->focus;
}

# Create modal 'Properties' dialog
sub propertiesDialog {
    # Return if the file does not exist
    return unless ( -e $tw->FileName() );
    my $popup = $mw->Dialog(
        -popover => $mw,
        -title   => 'Source File Properties',
        -bitmap  => 'info',
        -default_button => 'OK',
        -buttons => ['OK'],
        -text    => "Name:\t".basename($tw->FileName()).
                "\nSize:\t".(stat($tw->FileName()))[7]." Bytes\n".
                "Saved:\t".localtime((stat($tw->FileName()))[9])."\n".
                "Mode:\t".sprintf("%04o", 07777&(stat($tw->FileName()))[2])
        );
    $popup->resizable('no', 'no');
    $popup->Show();
}

# Run the script (currently with blocking the caller)
sub runScript {
    shift if UNIVERSAL::isa($_[0], 'TextHighlight');
    my $params = $_[0] ? $_[0] : '';

    if ( confirmCh() && -e $tw->FileName() ) {
        system("$^X \"".$tw->FileName()."\" $params");
    }
}

# Pop up a dialog box for the user to select a file to save
sub saveDialog {
    my $filename;
    shift if UNIVERSAL::isa($_[0], 'TextHighlight');

    if ( $_[0] eq 's' && $tw->FileName() ne 'Untitled' ) {
        $filename = $tw->FileName();
    }
    else {
        $filename = $mw->getSaveFile(-filetypes => \@filetypes,
                                     -initialfile => basename($tw->FileName()),
                                     -defaultextension => '.pl');
    }

    if ( defined $filename and $filename ne '' ) {
        if ( open(FILE, ">$filename") ) {
            # Write file to disk (change cursor to reflect this operation)
            $mw->Busy(-recurse => 1);
            my ($e_line) = split(/\./, $tw->index('end - 1 char'));
            foreach ( 1 .. $e_line-1 ) {
                print FILE $tw->get($_.'.0', $_.'.0 + 1 lines');
            }
            print FILE $tw->get($e_line.'.0', 'end - 1 char');
            $mw->Unbusy;
            close(FILE) or print "$!";
            $tw->FileName($filename);
            $nb->pageconfigure($nb->raised(), -label => basename($filename));
            $tw->numberChangesExt($tw->numberChanges);
            # Ensure 'File->Properties' menu entry is active
            $misc->cget(-menu)->entryconfigure(0 + ($Tk::platform eq 'unix'),
                                               -state => 'active');
        }
        else {
            my $msg = "File may be ReadOnly, or open for write by ".
                      "another application! Use 'Save As' to save ".
                      "as a different name.";
            $mw->Dialog(-popover => $mw, -text => $msg,
                        -bitmap => 'warning',
                        -title => 'Cannot save file',
                        -buttons => ['OK'])->Show;
        }
    }
}

# Update clock (without seconds) every minute
sub updateClock {
    ($clk = scalar localtime) =~ s/(\d+:\d+):(\d+)\s/$1 /;
    $mw->after((60-$2)*1000, \&updateClock);
}

# Update the statusbar
sub updateStatus {
    my ($cln, $ccol) = split(/\./, $tw->index('insert'));
    my ($lln) = split(/\./, $tw->index('end'));
    $st = "Line $cln (".($lln-1).'), Column '.($ccol+1);

    my $title = $nb->pagecget($nb->raised(), -label);
    # Check do we need to add/remove '*' from title
    if ( $tw->numberChanges != $tw->numberChangesExt() ) {
        if ( $title !~ /\*/ ) {
            $title .= '*';
            $nb->pageconfigure($nb->raised(), -label => $title);
        }
    }
    elsif ( $title =~ /\*/ ) {
        $title =~ s/\*//;
        $nb->pageconfigure($nb->raised(), -label => $title);
    }
}

# Write data to text widget via read buffer
sub writeData {
    my $filename = $tw->FileName();

    if ( -e $filename ) {
        open(FILE, $filename) or die "$!";
        my $read_buffer;
        while ( <FILE> ) {
            s/\x0D?\x0A/\n/ if ( $crlf );
            $read_buffer .= $_;
            if ( ($.%100) == 0 ) {
                $tw->insertWHL('end', $read_buffer);
                undef $read_buffer;
            }
        }
        if ( $read_buffer ) {
            $tw->insertWHL('end', $read_buffer);
        }
        close(FILE) or die "$!";
    }

    $tw->ResetUndo;
    # Set cursor to the first line of text widget
    $tw->insertWHL('0.0');
    $tw->backgroundHL(1);
}

__END__

=head1 NAME

T-Pad - A Perl/Tk GUI based Perl-script editor with syntax highlighting

=head1 SYNOPSIS

perl B<t-pad.pl> [I<file(s)-to-edit>]

=head1 DESCRIPTION

T-Pad is a Perl/Tk GUI based text editor with syntax highlight. T-Pad supports syntax highlight for *.pl, *.pm and *.cgi -files. It contains a command window to where a user can type commands to test for example a functionality of regular expression, evaluate Perl's predefined variables, look up documentation for built in functions etc.

=head1 README

A Perl/Tk GUI based Perl-script editor with syntax highlighting (*.pl, *.pm and *.cgi). T-Pad runs under Windows, Unix and Linux.

=head1 PREREQUISITES

This script requires the C<Tk> a graphical user interface toolkit module for Perl.

=head1 AUTHOR

Tomi Parviainen <F<tparviai@cpan.org>>

=head1 COPYRIGHT

Copyright (c) 2002-2003, Tomi Parviainen. All rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=pod SCRIPT CATEGORIES

Win32
Win32/Utilities

=cut