#!perl -w
#
# T-Pad - A Perl/Tk GUI based Perl-script editor with syntax highlighting
#
# Usage: see POD for details
#
use strict;
use Tk;

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

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

    my @FUNC = qw/AUTOLOAD BEGIN CORE DESTROY END 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/;

    for (@FUNC) { $FUNC{$_} = 1 } undef @FUNC;
    for (@FLOW) { $FLOW{$_} = 1 } undef @FLOW;
    for (@OPER) { $OPER{$_} = 1 } undef @OPER;

    use Tk qw(Ev);
    use AutoLoader;

    # Sets @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, '<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/));
        # Support for mouse wheel in Windows environment
        $w->bind('<MouseWheel>', [sub {
            $_[0]->yviewScroll(-($_[1]/120)*3, 'units');
        }, Tk::Ev('D')]);
        # Support for mouse wheel in UNIX environment
        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;
            });
        }
        $w->{'CHANGES'} = 0;
        $w->{'LINE'} = 0;
    }

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

    sub focusNext {
        # Prevent the focus be taken by scrollbar(s)
    }

    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'};
    }

    # Return filename without path
    sub FileNameExt {
        my $w = shift;
        return $w->FileName() =~ /^.*[\\\/]/ ? $' : $w->FileName();
    }

    # 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(@_);
        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 =~ /\$?"(\\.|[^"\\])*"|\$?'(\\.|[^'\\])*'/g ) {
                if ( $& =~ /^\$/ ) {
                    pos($line) = (pos($line)-length($')+1);
                    next;
                }
                $w->tagAdd('STRG', $ln.'.'.(length($`)),
                           $ln.'.'.pos($line));
            }
            # Highlight: comments
            while ( $line =~ m!/(\\.|[^/\\])*/|(\$|\\|)\#!g ) {
                next if ( length $& > 1 ||
                          $w->tagNames($ln.'.'.(pos($line)-1)) &&
                          $w->tagNames($ln.'.'.(pos($line)-1)) eq 'STRG' );
                $w->tagAdd('CMNT', $ln.'.'.(pos($line)-1), $ln.'.end');
                $line = $`;
            }
            # Highlight: functions, flow control words and operators,
            # do not highlight hashes, arrays or scalars
            while ( $line =~ /[\%\@\$]?\w+/g ) {
                if ( $OPER{$&} ) {
                    $w->tagAdd('OPER', $ln.'.'.(length($`)),
                               $ln.'.'.pos($line));
                }
                elsif ( $FLOW{$&} ) {
                    $w->tagAdd('FLOW', $ln.'.'.(length($`)),
                               $ln.'.'.pos($line));
                }
                elsif ( $FUNC{$&} || $& =~ /^\d+$/ ) {
                    $w->tagAdd('FUNC', $ln.'.'.(pos($line)-length($&)),
                               $ln.'.'.pos($line));
                }
            }
        }
    }
} # END - package TextHighlight

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

use Tk::HList;
use Tk::Dialog;
use Tk::Balloon;
use Tk::DropSite;
use Tk::NoteBook;

# 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 => '~Properties...',       -command => \&propertiesDialog],
        [Checkbutton => 'CR~LF Conversion', -variable => \my $crlf],
        '',
        [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 '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 entry widget where the user can type commands
my $cw = $mw->Entry(qw/-background white -relief ridge/)
            ->pack(qw/-side bottom -fill x -pady 2/);

$nb->pack(qw/-side top -expand 1 -fill both/);

# Command history
my @history = (0);

# Arrange for X events to invoke callbacks
$mw->bind('<Control-Tab>', [$cw, 'focus']);
$cw->bind('<Return>', \&executeCommand);
$cw->bind('<Escape>', sub { $tw->focus });
$cw->bind('<FocusOut>', sub { $history[0] = 0 });
$cw->bind('<Up>', [\&commandHistory, 'u']);
$cw->bind('<Down>', [\&commandHistory, 'd']);

# Start the GUI and eventloop
MainLoop;

#
# Create modal 'About' dialog (without possibility
# to resize the window) and wait for a response.
#
sub aboutDialog {
    my $popup = $mw->Dialog(
        -popover        => $mw,
        -title          => 'About T-Pad',
        -bitmap         => 'Tk',
        -default_button => 'OK',
        -buttons        => ['OK'],
        -text           => "T-Pad\nVersion 3.08 - 13-Apr-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' ) {
            $nb->raise($_);
            return;
        }
    }

    # Add new page with 'random' name to the notebook
    my $name = rand();
    my $page = $nb->add($name,
                        -label => $pageName =~ /^.*[\\\/]/ ? $' : $pageName,
                        -raisecmd => \&pageChanged);

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

    $tw->FileName($pageName);
    $pageName{$name} = $tw;

    $tw->bind('<FocusIn>',
    sub {
        $tw->tagRemove('MTCH', '0.0', 'end');
        $cw->delete(0, 'end');
    });
    # Change popup menu to contain 'Edit' menu entry
    $tw->menu($edit->menu);

    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 '.
                         $tw->FileNameExt(), -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 => 27)
                                ->pack(qw/-expand 1 -fill both/);

    my %commands = (
        'a' => 'About T-Pad',
        'c' => 'Close an opened script file',
        'eval x' => 'Evaluate expression \'x\'',
        'evali x' => 'Evaluate expression \'x\', insert result to text area',
        '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',
        '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',
        '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;
    });
}

#
# Change the content of the command window. User
# has pressed either 'Up' or 'Down' key.
#
sub commandHistory {
    # Ensure there are commands in history
    return if ( scalar(@history) == 1 );

    # Increment or decrement the command pointer
    if ( $_[1] eq 'u' && $history[0] < (1+20) ) {
        $history[0] += 1 if ( scalar(@history) > ($history[0]+1) );
    }
    elsif ( $_[1] eq 'd' && $history[0] ) {
        $history[0] -= 1;
    }

    # Delete text from command window and insert new if applicable
    $cw->delete(0, 'end');
    if ( $history[0] ) {
        $cw->insert(0, $history[scalar(@history)-$history[0]]);
    }
}

#
# Execute command given by the user
#
sub executeCommand {
    my $cmd = $cw->get();
    # Remove the command if it is already in array
    @history = grep($_ ne $cmd, @history);
    push @history, $cmd;
    # Remove oldest command from array if applicable
    splice(@history, 1, 1) if ( scalar(@history) > (1+20) );

    $cmd = ' [';
    if ( ($_ = $history[scalar(@history)-1]) =~ /^a$/ ) {
        $cmd .= 'About...';
        aboutDialog();
    }
    elsif ( /^c$/ ) {
        $cmd .= 'Close...';
        if ( keys %pageName > 1 ) {
            closeCommand();
        }
    }
    elsif ( /^eval(i*)\s(.+)$/ ) {
        $cmd .= eval $2 ? '='.eval $2 : 'undef';
        if ( $1 && $cmd =~ /=(.+)$/ ) { $tw->insert('insert', $1) }
    }
    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');
        }
        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;
        }
        # return because user might want to search again...
        return;
    }
    elsif ( /^g\s*(\d+)$/ ) {
        # 'space' after g is optional
        $cmd .= 'Goto line';
        $tw->markSet('insert', $1.'.0');
        $tw->see('insert');
        # Highlight the line for a while using MTCH tag
        $tw->tagAdd('MTCH', $1.'.0', $1.'.0 lineend + 1c');
        $tw->markUnset('insert');
    }
    elsif ( /^n$/ ) {
        $cmd .= 'New';
        addPage('Untitled');
    }
    elsif ( /^o$/ ) {
        $cmd .= 'Open...';
        openDialog();
    }
    elsif ( /^p$/ ) {
        $cmd .= 'Properties...';
        propertiesDialog();
    }
    elsif ( /^s$/ ) {
        $cmd .= 'Save';
        saveDialog('s');
    }
    elsif ( /^sa$/ ) {
        $cmd .= 'Save As...';
        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' }
        $cmd .= "Wrap $wm";
        $tw->configure(-wrap => $wm);
    }
    elsif ( /^x$/ ) {
        $cmd .= 'Exit';
        exitCommand();
    }
    else {
        # Not a valid command
        $cmd .= 'ERROR';
    }

    $cw->insert('end', "$cmd]");
    $cw->after(750, sub { $tw->focus });
}

#
# 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 );
}

#
# 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);
    }
}

#
# Handles 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 }
}

#
# 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 been changed, change the focus to the new page
# and initialise status bar to reflect page data
#
sub pageChanged {
    $tw = $pageName{$nb->raised()};
    $tw->focus;

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

#
# Create modal 'Properties' dialog (without possibility
# to resize the window) and wait for a response.
#
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".$tw->FileNameExt().
                "\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();
}

#
# 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 => $tw->FileNameExt(),
                                     -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 => $tw->FileNameExt());
            $tw->numberChangesExt($tw->numberChanges);
            # Ensure 'File->Properties' menu entry is active
            $file->cget(-menu)->entryconfigure(4 + ($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 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<tomi.parviainen@sunpoint.net>>

=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