File Coverage

blib/lib/Tcl/pTk/TkHijack.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1            
2 11     11   31721 use Tcl::pTk ( qw/ MainLoop DoOneEvent tkinit update Ev Exists /); # Don't import MainLoop, we create our own later
  0            
  0            
3            
4             package Tcl::pTk::TkHijack;
5            
6             our ($VERSION) = ('0.92');
7            
8             =head1 NAME
9            
10             Tcl::pTk::TkHijack - Run Existing Perl/tk Scripts with Tcl::pTk
11            
12            
13             =head1 SYNOPSIS
14            
15             # Run a existing perl/tk script 'tkscript.pl' with Tcl::pTk
16             perl -MTcl::pTk::TkHijack tkscript.pl
17            
18             # Alternatively, you can just put 'use Tcl::pTk::TkHijack' at the
19             # top of the 'tkscript.pl' file and just run it like normal
20            
21             =head1 DESCRIPTION
22            
23             I is an experimental module that makes existing perl/tk use L to run.
24             It 'Hijacks' any 'use Tk' and related calls in a perl/tk script to use Tcl::pTk.
25            
26             =head1 How It Works
27            
28             A sub ref (tkHijack) is pushed onto perl's global @INC array. This sub intercepts any 'use Tk'
29             or related calls and substitutes them with their Tcl::pTk equivalents. Additionally, some package aliases are setup between the Tk and the Tcl::pTk namespace
30            
31             =head1 Examples
32            
33             There are some examples of using TkHijack with a simple perl/tk script, and a perl/tk mega-widget. See
34             C and C in the source distribution.
35            
36             =head1 LIMITATIONS
37            
38             =over 1
39            
40             =item *
41            
42             XEvent calls are not translated, because there is no equivalent in Tcl::pTk (XEvent was a perl/tk specific addition to Tk, and doesn't exists in Tcl/Tk)
43            
44             =item *
45            
46             Perl/Tk widgets that use XS code can't be handled with this package.
47            
48             =back
49            
50             =cut
51            
52             our($debug, $translateList, $packageAliases, $aliasesMade);
53            
54             unshift @INC, \&TkHijack;
55            
56            
57             ######### Package Globals ####
58             $debug = 1;
59            
60            
61             # Mapping of Tk Packages that have equivalence in Tcl::pTk.
62             # If a Tk package is mapped to undef, then that means it's functionality is already included
63             # in the main Tcl::pTk package.
64             # This list is used for mapping "use" statements, for example if
65             # "use Tk::Tree" is encountered, the file "Tcl/pTk/Tree.pm" is loaded instead
66             $translateList = {
67             'Tk.pm' => '',
68             'Tk/Tree.pm' => 'Tcl/pTk/Tree.pm',
69             'Tk/Balloon.pm' => '',
70             'Tk/Bitmap.pm' => '',
71             'Tk/BrowseEntry.pm' => 'Tcl/pTk/BrowseEntry.pm',
72             'Tk/Canvas.pm' => 'Tcl/pTk/Canvas.pm',
73             'Tk/Clipboard.pm' => 'Tcl/pTk/Clipboard.pm',
74             'Tk/Dialog.pm' => '',
75             'Tk/DialogBox.pm' => '',
76             'Tk/DirTree.pm' => 'Tcl/pTk/DirTree.pm',
77             'Tk/DragDrop.pm' => 'Tcl/pTk/DragDrop.pm',
78             'Tk/DropSite.pm' => 'Tcl/pTk/DropSite.pm',
79             'Tk/Frame.pm' => '',
80             'Tk/Font.pm' => '',
81             'Tk/HList.pm' => 'Tcl/pTk/HList.pm',
82             'Tk/Image.pm' => 'Tcl/pTk/Image.pm',
83             'Tk/ItemStyle.pm' => 'Tcl/pTk/ItemStyle.pm',
84             'Tk/LabEntry.pm' => '',
85             'Tk/Listbox.pm' => 'Tcl/pTk/Listbox.pm',
86             'Tk/MainWindow.pm' => 'Tcl/pTk/MainWindow.pm',
87             'Tk/Photo.pm' => 'Tcl/pTk/Photo.pm',
88             'Tk/ProgressBar.pm' => 'Tcl/pTk/ProgressBar.pm',
89             'Tk/ROText.pm' => 'Tcl/pTk/ROText.pm',
90             'Tk/Table.pm' => 'Tcl/pTk/Table.pm',
91             'Tk/Text.pm' => 'Tcl/pTk/Text.pm',
92             'Tk/TextEdit.pm' => 'Tcl/pTk/TextEdit.pm',
93             'Tk/TextUndo.pm' => 'Tcl/pTk/TextUndo.pm',
94             'Tk/Toplevel.pm' => '',
95             'Tk/Tiler.pm' => 'Tcl/pTk/Tiler.pm',
96             'Tk/widgets.pm' => 'Tcl/pTk/widgets.pm',
97             'Tk/LabFrame.pm' => '',
98             'Tk/Submethods.pm' => 'Tcl/pTk/Submethods.pm',
99             'Tk/Menu.pm' => '',
100             'Tk/Wm.pm' => 'Tcl/pTk/Wm.pm',
101             'Tk/Widget.pm' => '',
102             'Tk/FileSelect.pm' => '',
103             'Tk/After.pm' => '',
104             'Tk/Derived.pm' => '',
105             'Tk/NoteBook.pm' => '',
106             'Tk/NBFrame.pm' => '',
107             'Tk/Pane.pm' => 'Tcl/pTk/Pane.pm',
108             'Tk/Adjuster.pm' => 'Tcl/pTk/Adjuster.pm',
109             'Tk/TableMatrix.pm' => 'Tcl/pTk/TableMatrix.pm',
110             'Tk/TableMatrix/Spreadsheet.pm' => 'Tcl/pTk/TableMatrix/Spreadsheet.pm',
111             'Tk/TableMatrix/SpreadsheetHideRows.pm' => 'Tcl/pTk/TableMatrix/SpreadsheetHideRows.pm',
112             'Tk/ErrorDialog.pm' => 'Tcl/pTk/ErrorDialog.pm',
113             };
114            
115            
116             # List of alias that will be created for Tk packages to Tcl::pTk packages
117             # This is to make megawidgets created in Tk work. For example,
118             # if a Tk mega widget has the following code:
119             # use base(qw/ Tk::Frame /);
120             # Construct Tk::Widget 'SlideSwitch'
121             # The aliases below will essentially translate to code to mean:
122             # use base(qw/ Tcl::pTk::Frame /);
123             # Construct Tcl::pTk::Widget 'SlideSwitch'
124             #
125             $packageAliases = {
126             'Tk::Frame' => 'Tcl::pTk::Frame',
127             'Tk::Toplevel' => 'Tcl::pTk::Toplevel',
128             'Tk::MainWindow' => 'Tcl::pTk::MainWindow',
129             'Tk::Widget'=> 'Tcl::pTk::Widget',
130             'Tk::Derived'=> 'Tcl::pTk::Derived',
131             'Tk::DropSite' => 'Tcl::pTk::DropSite',
132             'Tk::Canvas' => 'Tcl::pTk::Canvas',
133             'Tk::Menu'=> 'Tcl::pTk::Menu',
134             'Tk::TextUndo'=> 'Tcl::pTk::TextUndo',
135             'Tk::Text'=> 'Tcl::pTk::Text',
136             'Tk::Tree'=> 'Tcl::pTk::Tree',
137             'Tk::Clipboard'=> 'Tcl::pTk::Clipboard',
138             'Tk::Configure'=> 'Tcl::pTk::Configure',
139             'Tk::BrowseEntry'=> 'Tcl::pTk::BrowseEntry',
140             'Tk::Callback'=> 'Tcl::pTk::Callback',
141             'Tk::TableMatrix'=> 'Tcl::pTk::TableMatrix',
142             'Tk::Table'=> 'Tcl::pTk::Table',
143             'Tk::TableMatrix::Spreadsheet'=> 'Tcl::pTk::TableMatrix::Spreadsheet',
144             'Tk::TableMatrix::SpreadsheetHideRows'=> 'Tcl::pTk::TableMatrix::SpreadsheetHideRows',
145             };
146            
147             ######### End of Package Globals ###########
148             # Alias Packages
149             aliasPackages($packageAliases);
150            
151            
152            
153            
154            
155             sub TkHijack {
156             # When placed first on the INC path, this will allow us to hijack
157             # any requests for 'use Tk' and any Tk::* modules and replace them
158             # with our own stuff.
159             my ($coderef, $module) = @_; # $coderef is to myself
160             #print "TkHijack encoutering $module\n";
161             return undef unless $module =~ m!^Tk(/|\.pm$)!;
162            
163             #print "TkHijack $module\n";
164            
165             my ($package, $callerfile, $callerline) = caller;
166             #print "TkHijack package/callerFile/callerline = $package $callerfile $callerline\n";
167            
168             my $mapped = $translateList->{$module};
169            
170             if( defined($mapped) && !$mapped){ # Module exists in translateList, but no mapped file
171             my $fakefile;
172             open(my $fh, '<', \$fakefile) || die "oops"; # open a file "in-memory"
173            
174             $module =~ s!/!::!g;
175             $module =~ s/\.pm$//;
176            
177             # Make Version if importing Tk (needed for some scripts to work right)
178             my $versionText = "\n";
179             my $requireText = "\n"; # if Tk module, set export of Ev subs
180             if( $module eq 'Tk' ){
181            
182             $requireText = "use Exporter 'import';\n";
183             $requireText .= '@EXPORT_OK = (qw/ Ev catch/);'."\n";
184            
185             $versionText = '$Tk::VERSION = 805.001;'."\n";
186            
187             # Redefine common Tk subs/variables to Tcl::pTk equivalents
188             no warnings;
189             *Tk::MainLoop = \&Tcl::pTk::MainLoop;
190             *Tk::findINC = \&Tcl::pTk::findINC;
191             *Tk::after = \&Tcl::pTk::after;
192             *Tk::DoOneEvent = \&Tcl::pTk::DoOneEvent;
193             *Tk::Ev = \&Tcl::pTk::Ev;
194             *Tk::Exists = \&Tcl::pTk::Exists;
195             *Tk::break = \&Tcl::pTk::break;
196             *Tk::platform = \$Tcl::pTk::platform;
197             *Tk::timeofday = \&Tcl::pTk::timeofday;
198             *Tk::fileevent = \&Tcl::pTk::fileevent;
199             *Tk::bind = \&Tcl::pTk::Widget::bind;
200             *Tk::ACTIVE_BG = \&Tcl::pTk::ACTIVE_BG;
201             *Tk::NORMAL_BG = \&Tcl::pTk::NORMAL_BG;
202             *Tk::SELECT_BG = \&Tcl::pTk::SELECT_BG;
203            
204            
205             }
206            
207            
208             $fakefile = <
209             package $module;
210             $requireText
211             $versionText
212             #warn "### $callerfile:$callerline not really loading $module ###" if($Tcl::pTk::TkHijack::debug);
213             sub foo { 1; }
214             1;
215             EOS
216             return $fh;
217             }
218             elsif( defined($mapped) ){ # Module exists in translateList with a mapped file
219            
220             # Turn mapped file into name suitable for a 'use' statement
221             my $usefile = $mapped;
222             $usefile =~ s!/!::!g;
223             $usefile =~ s/\.pm$//;
224            
225             #warn "### $callerfile:$callerline loading Tcl Tk $usefile to substitute for $module ###" if($Tcl::pTk::TkHijack::debug);
226             # Turn mapped file into use statement
227             my $fakefile;
228             open(my $fh, '<', \$fakefile) || die "oops"; # open a file "in-memory"
229             $fakefile = <
230             use $usefile;
231             1;
232             EOS
233             return $fh;
234             }
235             else{
236             #warn("Warning No Tcl::pTk Equivalent to $module from $callerfile line $callerline, loading anyway...\n") if $debug;
237             }
238            
239             }
240            
241             ############## Sub To Alias Packages ########
242             sub aliasPackages{
243             my $aliases = shift;
244             my $aliasTo;
245             foreach my $aliasFrom ( keys %$aliases){
246             $aliasTo = $packageAliases->{$aliasFrom};
247             *{$aliasFrom.'::'} = *{$aliasTo.'::'};
248             }
249             }
250            
251            
252             ################### MainWindow package #################3
253             ## Created so the lines like the following work
254             ## my $mw = new MainWindow;
255             package MainWindow;
256            
257             sub new{
258             Tcl::pTk::MainWindow();
259             }
260            
261             1;