package Tk;

# We need to add ../lib to @INC for now otherwise Exporter.pm will not be
# found. Moreover, it has to be surrounded by BEGIN { } otherwise the
# implied BEGIN { } around the 'require Exporter' will beat us to it.
BEGIN {
    push(@INC, "../lib");
}
require Exporter;
@ISA = (Exporter);
@EXPORT = qw(grabcurrent grabrelease grab grabstatus tcleval tclevalfile
             tclcmd tkinit tkmainloop tkbind tkpack wm focus focusdefault
             after destroy lower raise waitvar waitvis waitwin update
             idletasks addasyncio delasyncio EvWref path optadd optclear
             optget optaddstring);

bootstrap Tk;
bootstrap Frame;
bootstrap Button;
bootstrap Entry;
bootstrap Listbox;
bootstrap Menu;
bootstrap Menubutton;
bootstrap Message;
bootstrap Scale;
bootstrap Scrollbar;

sub tkinit {
    local($name, $display, $sync) = @_;
    local($top);

    $display = $ENV{DISPLAY} unless $display;
    die "no display argument and no DISPLAY in environment" unless $display;
    
    ($name = $0) =~ s:^[^/]*/:: unless $name;
    die 'no name set and $0 not appropriate' unless $name;
 
    $top = init($name, $display, $sync);

# Now initialise all necessary classes by going through the packages named in
# @Tk::CLASSINIT and invoking the method 'classinit' in each one. It is
# initialised by the 'require Tk' done at parse time but can get changed or
# added to before tkinit is called. This is so that the user can alter the
# default bindings (by redeclaring a Widget::classinit) and so that widget
# writers have a hook to initialise their own widgets at tkinit time.
# We pass in a few arguments just in case they are wanted (unlikely.)
    foreach $pack (@CLASSINIT) {
        classinit $pack $name, $display, $sync;
    }
    return $top;
}

#
# Now for the various support routines used by the standard bindings
#

sub butEnter {
    local($w) = &EvWref;
    return if ($w->configure("-state"))[4] eq "disabled";
    $w->configure("-state" => "active") unless $strictMotif;
    $tkpriv::window = $EvW;
}
sub butLeave {
    local($w) = &EvWref;
    return if ($w->configure("-state"))[4] eq "disabled";
    $w->configure("-state" => "normal") unless $strictMotif;
    undef $tkpriv::window;
}
sub butDown {
    local($w) = &EvWref;
    $tkpriv::relief = ($w->configure("-relief"))[4];
    $tkpriv::buttonWindow = $EvW;
    $w->configure("-relief" => "sunken")
        unless ($w->configure("-state"))[4] eq "disabled";
}
sub butUp {
    local($w) = &EvWref;
    return unless $EvW eq $tkpriv::buttonWindow;
    $w->configure("-relief" => $tkpriv::relief);
    $w->invoke() if $EvW eq $tkpriv::window
               && ($w->configure("-state"))[4] ne "disabled";
    undef $tkpriv::buttonWindow;
}

sub entryBackspace {
    local($w) = &EvWref;
    local($x) = $w->tkindex("insert") - 1;
    $w->tkdelete($x) unless $x == -1;
    entrySeeCaret;
}

sub entryBackword {
    local($w) = &EvWref;
    local($curs) = $w->tkindex("insert") - 1;
    return if $curs < 0;
    $_ = substr($w->get(), 0, $curs + 1);
    s/[^ \t]+[ \t]*$//;
    $w->tkdelete(length, $curs);
    entrySeeCaret;
}

sub entrySeeCaret {
    local($w) = &EvWref;
    local($c) = $w->tkindex("insert");
    local($left) = $w->tkindex('@0');
    if ($left >= $c) {
        $c-- if $c > 0;
        $w->view($c);
    } else {
        while ($w->tkindex('@' . (tclcmd("winfo", "width", $$w) - 5)) < $c
               && $left < $c) {
            $w->view(++$left);
        }
    }
}
        
sub entrySelectStart {
    local($w) = &EvWref;
    $w->icursor('@' . $Evx);
    $w->selectfrom('@' . $Evx);
    focus($w) if ($w->configure("-state"))[4] eq "normal";
}

sub entrySelectTo {
    local($w) = &EvWref;
    $w->selectto('@' . $Evx);
}

sub entrySelectAdjust {
    local($w) = &EvWref;
    $w->selectadjust('@' . $Evx);
}

sub entryScanMark {
    local($w) = &EvWref;
    $w->scanmark($Evx);
}

sub entryScanDragto {
    local($w) = &EvWref;
    $w->scandragto($Evx);
}

sub entryKeyPress {
    local($key) = $EvA;
    local($w) = &EvWref;
    if ($key !~ /^$/) {
        $w->insert("insert", $key);
        entrySeeCaret;
    }
}

sub entryDeleteSelection {
    local($w) = &EvWref;
    $w->tkdelete("sel.first", "sel.last");
    entrySeeCaret;
}

sub entryInsertSelection {
    local($w) = &EvWref;
    $w->insert("insert", tclcmd("selection", "get"));
    entrySeeCaret;
}

sub entryDeleteAll {
    local($w) = &EvWref;
    $w->tkdelete(0, "end");
}

sub listboxSelectFrom {
    local($w) = &EvWref;
    $w->selectfrom($w->nearest($Evy));
}

sub listboxSelectTo {
    local($w) = &EvWref;
    $w->selectto($w->nearest($Evy));
}

sub listboxSelectAdjust {
    local($w) = &EvWref;
    $w->selectadjust($w->nearest($Evy));
}

sub listboxScanMark {
    local($w) = &EvWref;
    $w->scanmark($Evx, $Evy);
}

sub listboxScanDragto {
    local($w) = &EvWref;
    $w->scandragto($Evx, $Evy);
}

sub scrollbarEnter {
    local($w) = &EvWref;
    return unless $strictMotif;
    $tkpriv::activeFg = ($w->configure("-activeforeground"))[4];
    $w->configure("-activeforeground" => ($w->configure("-foreground"))[4]);
}

sub scrollbarLeave {
    return unless $strictMotif && $tkpriv::buttons == 0;
    &EvWref->configure("-activeforeground" => $tkpriv::activeFg);
}

sub incrbuttons {
    $tkpriv::buttons++;
}

sub decrbuttons {
    $tkpriv::buttons--;
}    

sub scaleEnter {
    local($w) = &EvWref;
    return unless $strictMotif;
    $tkpriv::activeFg = ($w->configure("-activeforeground"))[4];
    $w->configure("-activeforeground" =>
                  ($w->configure("-sliderforeground"))[4]);
}

sub scaleLeave {
    return unless $strictMotif && $tkpriv::buttons == 0;
    &EvWref->configure("-activeforeground" => $tkpriv::activeFg);
}

sub mbPost {
    local($w) = @_;
    local($menu, $cur, $grab, $x, $y);
    $w = &EvWref() unless defined($w);
    return if ($w->configure("-state"))[4] eq "disabled";
    if (defined($tkpriv::posted)) {
        if ($$w eq $$tkpriv::posted) {
            grab($tkpriv::grab, 1);
            return;
        }
    }
    $menu = ($w->configure("-menu"))[4];
    return unless defined($menu);
# should check here that $menu is a descendant of $w
    $cur = $tkpriv::posted;
    mbUnpost if defined($cur);
    $tkpriv::relief = ($w->configure("-relief"))[4];
    $w->configure("-relief" => "raised");
    $tkpriv::posted = $w;
    $tkpriv::focus = focus() unless defined($tkpriv::focus);
    $tkpriv::activeBg = ($w->configure("-activebackground"))[4];
    $tkpriv::activeFg = ($w->configure("-activeforeground"))[4];
    if ($strictMotif) {
        $menu->configure("-activebackground" =>
                         ($menu->configure("-background"))[4]);
        $menu->configure("-activeforeground" =>
                         ($menu->configure("-foreground"))[4]);
    }
    $menu->activate("none");
    focus($menu);
    $x = tclcmd("winfo", "rootx", $$w);
    $y = tclcmd("winfo", "rooty", $$w) + tclcmd("winfo", "height", $$w);
    $menu->post($x, $y);
# some stuff for menu bars should go here
    $grab = $w; 
    $tkpriv::cursor = ($grab->configure("-cursor"))[4];
    $grab->configure("-cursor" => "arrow");
    $tkpriv::grab = $grab;
    grab($grab, 1);
}

sub mbUnpost {
    local($w) = $tkpriv::posted;
    local($menu);
    return unless defined($w);
# following section should be eval'd when that is implemented
    $menu = ($w->configure("-menu"))[4];
    $menu->unpost();
    $menu->configure("-activebackground" => $tkpriv::activeBg);
    $menu->configure("-activeforeground" => $tkpriv::activeFg);
    $w->configure("-relief" => $tkpriv::relief);
# end of section that should be eval'd
# following single line should be eval'd too
    $tkpriv::grab->configure("-cursor" => $tkpriv::cursor);
    focus($tkpriv::focus);
    grabrelease($tkpriv::grab);
    undef $tkpriv::focus;
    undef $tkpriv::posted;
}

sub invokeMenu {
    local($menu) = @_;
    local($i);
    $menu = &EvWref unless defined($menu);
    $i = $menu->tkindex("active");
    return unless defined($i);
    mbUnpost;
    idletasks;
    $menu->invoke($i);
}

sub mbButtonDown {
    local($w) = &EvWref;
    return if ($w->configure("-state"))[4] eq "disabled"
               || !defined($tkpriv::inMenuButton);
    mbPost($w) if $$tkpriv::inMenuButton eq $$w;
}

sub mbEnter {
    local($w) = &EvWref;
    $tkpriv::inMenuButton = $w;
    return if $strictMotif || ($w->configure("-state"))[4] eq "disabled";
    $w->configure("-state" => "active");
}

sub mbLeave {
    local($w) = &EvWref;
    undef $tkpriv::inMenuButton;
    $w->configure("-state" => "normal")
        if ($w->configure("-state"))[4] eq "active";
}

sub mbRelease {
    local($w) = &EvWref;
    local($menu);
    if (!defined($tkpriv::posted) || !defined($tkpriv::inMenuButton)) {
        mbUnpost;
    } else {
        if ($$tkpriv::posted eq $EvW && $$tkpriv::inMenuButton eq $EvW) {
	    $menu = ($tkpriv::posted->configure("-menu"))[4];
	    $menu->activate(0);
        }
    }
}

sub mbB1Enter {
    local($w) = &EvWref;
    $tkpriv::inMenuButton = $w;
    return if ($w->configure("-state"))[4] eq "disabled"
               || !defined($tkpriv::posted);
    $w->configure("-state" => "active") unless $strictMotif;
    mbPost($w);
}

sub mbDragStart {
    local($w) = &EvWref;
    return unless defined($tkpriv::posted)
                  && ($w->configure("-state"))[4] ne "disabled";
    $tkpriv::dragging = $w;
    (($w->configure("-menu"))[4])->post($EvX, $EvY);
}

sub mbDragMotion {
    (($tkpriv::dragging->configure("-menu"))[4])->post($EvX, $EvY)
        if defined($tkpriv::dragging);
}

sub mbDragStop {
    undef $tkpriv::dragging;
}

sub menuEnter {
    local($w) = &EvWref;
    $tkpriv::window = $w;
    $w->activate('@' . $Evy);
}

sub menuLeave {
    undef $tkpriv::window;
    &EvWref->activate("none");
}

sub menuMotion {
    &EvWref->activate('@' . $Evy) if $$tkpriv::window eq $EvW;
}

sub menuDown {
    grab($tkpriv::grab) if defined($tkpriv::grab);
}

sub menuDragStart {
    $tkpriv::x = $Evx;
    $tkpriv::y = $Evy;
}

sub menuDragMotion {
    &EvWref->post($EvX - $tkpriv::x, $EvY - $tkpriv::y)
        if defined($tkpriv::posted);
}

sub Button::classinit {
    foreach $class ("Button", "Checkbutton", "Radiobutton") {
        tkbind($class, "<Any-Enter>", "Tk::butEnter");
        tkbind($class, "<Any-Leave>", "Tk::butLeave");
        tkbind($class, "<1>", "Tk::butDown");
        tkbind($class, "<ButtonRelease-1>", "Tk::butUp");
    }
}

sub Entry::classinit {
    tkbind("Entry", "<1>", "Tk::entrySelectStart");
    tkbind("Entry", "<B1-Motion>", "Tk::entrySelectTo");
    tkbind("Entry", "<Shift-1>", "Tk::entrySelectAdjust");
    tkbind("Entry", "<Shift-B1-Motion>", "Tk::entrySelectTo");
    tkbind("Entry", "<2>", "Tk::entryScanMark");
    tkbind("Entry", "<B2-Motion>", "Tk::entryScanDragto");
    tkbind("Entry", "<Any-KeyPress>", "Tk::entryKeyPress");
    tkbind("Entry", "<Delete>", "Tk::entryBackspace");
    tkbind("Entry", "<BackSpace>", "Tk::entryBackspace");
    tkbind("Entry", "<Control-h>", "Tk::entryBackspace");
    tkbind("Entry", "<Control-d>", "Tk::entryDeleteSelection");
    tkbind("Entry", "<Control-u>", "Tk::entryDeleteAll");
    tkbind("Entry", "<Control-v>", "Tk::entryInsertSelection");
    tkbind("Entry", "<Control-w>", "Tk::entryBackword");
}

sub Listbox::classinit {
    tkbind("Listbox", "<1>", "Tk::listboxSelectFrom");
    tkbind("Listbox", "<B1-Motion>", "Tk::listboxSelectTo");
    tkbind("Listbox", "<Shift-1>", "Tk::listboxSelectAdjust");
    tkbind("Listbox", "<Shift-B1-Motion>", "Tk::listboxSelectTo");
    tkbind("Listbox", "<2>", "Tk::listboxScanMark");
    tkbind("Listbox", "<B2-Motion>", "Tk::listboxScanDragto");
}

sub Scrollbar::classinit {
    tkbind("Scrollbar", "<Any-Enter>", "Tk::scrollbarEnter");
    tkbind("Scrollbar", "<Any-Leave>", "Tk::scrollbarLeave");
    tkbind("Scrollbar", "<Any-ButtonPress>", "Tk::incrbuttons");
    tkbind("Scrollbar", "<Any-ButtonRelease>", "Tk::decrbuttons");
}

sub Scale::classinit {
    tkbind("Scale", "<Any-Enter>", "Tk::scaleEnter");
    tkbind("Scale", "<Any-Leave>", "Tk::scaleLeave");
    tkbind("Scale", "<Any-ButtonPress>", "Tk::incrbuttons");
    tkbind("Scale", "<Any-ButtonRelease>", "Tk::decrbuttons");
}

sub Menubutton::classinit {
    tkbind("Menubutton", "<Any-Enter>", "Tk::mbEnter");
    tkbind("Menubutton", "<Any-Leave>", "Tk::mbLeave");
    tkbind("Menubutton", "<1>", "Tk::mbButtonDown");
    tkbind("Menubutton", "<Any-ButtonRelease-1>", "Tk::mbRelease");
    tkbind("Menubutton", "<B1-Enter>", "Tk::mbB1Enter");
    tkbind("Menubutton", "<2>", "Tk::mbDragStart");
    tkbind("Menubutton", "<B2-Motion>", "Tk::mbDragMotion");
    tkbind("Menubutton", "<ButtonRelease-2>", "Tk::mbDragStop");
}

sub Menu::classinit {
    tkbind("Menu", "<Any-Enter>", "Tk::menuEnter");
    tkbind("Menu", "<Any-Leave>", "Tk::menuLeave");
    tkbind("Menu", "<Any-Motion>", "Tk::menuMotion");
    tkbind("Menu", "<1>", "Tk::menuDown");
    tkbind("Menu", "<ButtonRelease-1>", "Tk::invokeMenu");
    tkbind("Menu", "<2>", "Tk::menuDragStart");
    tkbind("Menu", "<B2-Motion>", "Tk::menuDragMotion");
}

# The following list will be looked at  when tkinit is called and the
# method classinit invoked in each package in the list
@CLASSINIT = (Button, Entry, Listbox, Scrollbar, Scale, Menubutton, Menu);

1;
