view release on metacpan or  search on metacpan

lib/Tcl/pTk/TkHijack.pm  view on Meta::CPAN

        'Tk/BrowseEntry.pm'    =>  'Tcl/pTk/BrowseEntry.pm',
        'Tk/Canvas.pm'    =>  'Tcl/pTk/Canvas.pm',
        'Tk/Clipboard.pm'    =>  'Tcl/pTk/Clipboard.pm',
        'Tk/Dialog.pm'    =>  '',
        'Tk/DialogBox.pm'    =>  '',
        'Tk/DirTree.pm'    =>  'Tcl/pTk/DirTree.pm',
        'Tk/DragDrop.pm'    =>  'Tcl/pTk/DragDrop.pm',
        'Tk/DropSite.pm'    =>  'Tcl/pTk/DropSite.pm',
        'Tk/Frame.pm'       =>  '',
        'Tk/Font.pm'       =>  '',
        'Tk/HList.pm'    =>  'Tcl/pTk/HList.pm',
        'Tk/Image.pm'    =>  'Tcl/pTk/Image.pm',
        'Tk/ItemStyle.pm'    =>  'Tcl/pTk/ItemStyle.pm',
        'Tk/LabEntry.pm'    =>  '',
        'Tk/Listbox.pm'    =>  'Tcl/pTk/Listbox.pm',
        'Tk/MainWindow.pm'    =>  'Tcl/pTk/MainWindow.pm',
        'Tk/Photo.pm'    =>  'Tcl/pTk/Photo.pm',
        'Tk/ProgressBar.pm'    =>  'Tcl/pTk/ProgressBar.pm',
        'Tk/ROText.pm'    =>  'Tcl/pTk/ROText.pm',
        'Tk/Table.pm'    =>  'Tcl/pTk/Table.pm',
        'Tk/Text.pm'    =>  'Tcl/pTk/Text.pm',
        'Tk/TextEdit.pm'    =>  'Tcl/pTk/TextEdit.pm',
        'Tk/TextUndo.pm'    =>  'Tcl/pTk/TextUndo.pm',
        'Tk/Toplevel.pm'    =>  '',
        'Tk/Tiler.pm'    =>  'Tcl/pTk/Tiler.pm',
        'Tk/widgets.pm' =>  'Tcl/pTk/widgets.pm',
        'Tk/LabFrame.pm' => '',
        'Tk/Submethods.pm' => 'Tcl/pTk/Submethods.pm',
        'Tk/Menu.pm'       => '',
        'Tk/Wm.pm'            => 'Tcl/pTk/Wm.pm',
        'Tk/Widget.pm'      => '',
        'Tk/FileSelect.pm'      => '',
        'Tk/After.pm'       => '',
        'Tk/Derived.pm'     => '',
        'Tk/NoteBook.pm'     => '',
        'Tk/NBFrame.pm'     => '',
        'Tk/Pane.pm'     => 'Tcl/pTk/Pane.pm',
        'Tk/Adjuster.pm'     => 'Tcl/pTk/Adjuster.pm',
        'Tk/TableMatrix.pm'     => 'Tcl/pTk/TableMatrix.pm',
        'Tk/TableMatrix/Spreadsheet.pm'     => 'Tcl/pTk/TableMatrix/Spreadsheet.pm',
        'Tk/TableMatrix/SpreadsheetHideRows.pm'     => 'Tcl/pTk/TableMatrix/SpreadsheetHideRows.pm',
        'Tk/ErrorDialog.pm'     => 'Tcl/pTk/ErrorDialog.pm',
};


# List of alias that will be created for Tk packages to Tcl::pTk packages
#   This is to make megawidgets created in Tk work. For example,
#     if a Tk mega widget has the following code:
#       use base(qw/ Tk::Frame /);
#       Construct Tk::Widget 'SlideSwitch'
#     The aliases below will essentially translate to code to mean:
#       use base(qw/ Tcl::pTk::Frame /);
#       Construct Tcl::pTk::Widget 'SlideSwitch'
#
$packageAliases = {
        'Tk::widgets' => 'Tcl::pTk::widgets',
        'Tk::Frame' => 'Tcl::pTk::Frame',
        'Tk::Toplevel' => 'Tcl::pTk::Toplevel',
        'Tk::MainWindow' => 'Tcl::pTk::MainWindow',
        'Tk::Widget'=> 'Tcl::pTk::Widget',
        'Tk::Derived'=> 'Tcl::pTk::Derived',
        'Tk::DropSite'    =>  'Tcl::pTk::DropSite',
        'Tk::Canvas'    =>  'Tcl::pTk::Canvas',
        'Tk::Menu'=> 'Tcl::pTk::Menu',
        'Tk::TextUndo'=> 'Tcl::pTk::TextUndo',
        'Tk::Text'=> 'Tcl::pTk::Text',
        'Tk::Tree'=> 'Tcl::pTk::Tree',
        'Tk::Clipboard'=> 'Tcl::pTk::Clipboard',
        'Tk::Configure'=> 'Tcl::pTk::Configure',
        'Tk::BrowseEntry'=> 'Tcl::pTk::BrowseEntry',
        'Tk::Callback'=> 'Tcl::pTk::Callback',
        'Tk::TableMatrix'=> 'Tcl::pTk::TableMatrix',
        'Tk::Table'=> 'Tcl::pTk::Table',
        'Tk::TableMatrix::Spreadsheet'=> 'Tcl::pTk::TableMatrix::Spreadsheet',
        'Tk::TableMatrix::SpreadsheetHideRows'=> 'Tcl::pTk::TableMatrix::SpreadsheetHideRows',
};

######### End of Package Globals ###########
# Alias Packages
aliasPackages($packageAliases);





sub TkHijack {
    # When placed first on the INC path, this will allow us to hijack
    # any requests for 'use Tk' and any Tk::* modules and replace them
    # with our own stuff.
    my ($coderef, $module) = @_;  # $coderef is to myself
    #print "TkHijack encoutering $module\n";
    return undef unless $module =~ m!^Tk(/|\.pm$)!;

    #print "TkHijack $module\n";

    my ($package, $callerfile, $callerline) = caller;
    #print "TkHijack package/callerFile/callerline = $package $callerfile $callerline\n";

    my $mapped = $translateList->{$module};

    if( defined($mapped) && !$mapped){ # Module exists in translateList, but no mapped file
            my $fakefile;
            open(my $fh, '<', \$fakefile) || die "oops"; # open a file "in-memory"

            $module =~ s!/!::!g;
            $module =~ s/\.pm$//;

            # Make Version if importing Tk (needed for some scripts to work right)
            my $versionText = "\n";
            my $requireText = "\n"; #  if Tk module, set export of Ev subs
            if( $module eq 'Tk' ){

                    $requireText = "use Exporter 'import';\n";
                    $requireText .= '@EXPORT_OK = (qw/ Ev catch/);'."\n";

                    $versionText = '$Tk::VERSION = 805.001;'."\n";

                    # Redefine common Tk subs/variables to Tcl::pTk equivalents
                    no warnings;
                    *Tk::MainLoop = \&Tcl::pTk::MainLoop;
                    *Tk::findINC = \&Tcl::pTk::findINC;