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 8     8   34370 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.85');
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             ######### Package Globals ####
57             $debug = 1;
58              
59              
60             # Mapping of Tk Packages that have equivalence in Tcl::pTk.
61             # If a Tk package is mapped to undef, then that means it's functionality is already included
62             # in the main Tcl::pTk package.
63             # This list is used for mapping "use" statements, for example if
64             # "use Tk::Tree" is encountered, the file "Tcl/pTk/Tree.pm" is loaded instead
65             $translateList = {
66             'Tk.pm' => '',
67             'Tk/Tree.pm' => 'Tcl/pTk/Tree.pm',
68             'Tk/Balloon.pm' => '',
69             'Tk/Bitmap.pm' => '',
70             'Tk/BrowseEntry.pm' => 'Tcl/pTk/BrowseEntry.pm',
71             'Tk/Canvas.pm' => 'Tcl/pTk/Canvas.pm',
72             'Tk/Clipboard.pm' => 'Tcl/pTk/Clipboard.pm',
73             'Tk/Dialog.pm' => '',
74             'Tk/DialogBox.pm' => '',
75             'Tk/DirTree.pm' => 'Tcl/pTk/DirTree.pm',
76             'Tk/DragDrop.pm' => 'Tcl/pTk/DragDrop.pm',
77             'Tk/DropSite.pm' => 'Tcl/pTk/DropSite.pm',
78             'Tk/Frame.pm' => '',
79             'Tk/Font.pm' => '',
80             'Tk/HList.pm' => 'Tcl/pTk/HList.pm',
81             'Tk/Image.pm' => 'Tcl/pTk/Image.pm',
82             'Tk/ItemStyle.pm' => 'Tcl/pTk/ItemStyle.pm',
83             'Tk/LabEntry.pm' => '',
84             'Tk/Listbox.pm' => 'Tcl/pTk/Listbox.pm',
85             'Tk/MainWindow.pm' => 'Tcl/pTk/MainWindow.pm',
86             'Tk/Photo.pm' => 'Tcl/pTk/Photo.pm',
87             'Tk/ProgressBar.pm' => 'Tcl/pTk/ProgressBar.pm',
88             'Tk/ROText.pm' => 'Tcl/pTk/ROText.pm',
89             'Tk/Table.pm' => 'Tcl/pTk/Table.pm',
90             'Tk/Text.pm' => 'Tcl/pTk/Text.pm',
91             'Tk/TextEdit.pm' => 'Tcl/pTk/TextEdit.pm',
92             'Tk/TextUndo.pm' => 'Tcl/pTk/TextUndo.pm',
93             'Tk/Toplevel.pm' => '',
94             'Tk/Tiler.pm' => 'Tcl/pTk/Tiler.pm',
95             'Tk/widgets.pm' => 'Tcl/pTk/widgets.pm',
96             'Tk/LabFrame.pm' => '',
97             'Tk/Submethods.pm' => 'Tcl/pTk/Submethods.pm',
98             'Tk/Menu.pm' => '',
99             'Tk/Wm.pm' => 'Tcl/pTk/Wm.pm',
100             'Tk/Widget.pm' => '',
101             'Tk/FileSelect.pm' => '',
102             'Tk/After.pm' => '',
103             'Tk/Derived.pm' => '',
104             'Tk/NoteBook.pm' => '',
105             'Tk/NBFrame.pm' => '',
106             'Tk/Pane.pm' => 'Tcl/pTk/Pane.pm',
107             'Tk/Adjuster.pm' => 'Tcl/pTk/Adjuster.pm',
108             'Tk/TableMatrix.pm' => 'Tcl/pTk/TableMatrix.pm',
109             'Tk/TableMatrix/Spreadsheet.pm' => 'Tcl/pTk/TableMatrix/Spreadsheet.pm',
110             'Tk/TableMatrix/SpreadsheetHideRows.pm' => 'Tcl/pTk/TableMatrix/SpreadsheetHideRows.pm',
111             };
112              
113              
114             # List of alias that will be created for Tk packages to Tcl::pTk packages
115             # This is to make megawidgets created in Tk work. For example,
116             # if a Tk mega widget has the following code:
117             # use base(qw/ Tk::Frame /);
118             # Construct Tk::Widget 'SlideSwitch'
119             # The aliases below will essentially translate to code to mean:
120             # use base(qw/ Tcl::pTk::Frame /);
121             # Construct Tcl::pTk::Widget 'SlideSwitch'
122             #
123             $packageAliases = {
124             'Tk::Frame' => 'Tcl::pTk::Frame',
125             'Tk::Toplevel' => 'Tcl::pTk::Toplevel',
126             'Tk::MainWindow' => 'Tcl::pTk::MainWindow',
127             'Tk::Widget'=> 'Tcl::pTk::Widget',
128             'Tk::Derived'=> 'Tcl::pTk::Derived',
129             'Tk::DropSite' => 'Tcl::pTk::DropSite',
130             'Tk::Canvas' => 'Tcl::pTk::Canvas',
131             'Tk::Menu'=> 'Tcl::pTk::Menu',
132             'Tk::TextUndo'=> 'Tcl::pTk::TextUndo',
133             'Tk::Text'=> 'Tcl::pTk::Text',
134             'Tk::Tree'=> 'Tcl::pTk::Tree',
135             'Tk::Clipboard'=> 'Tcl::pTk::Clipboard',
136             'Tk::Configure'=> 'Tcl::pTk::Configure',
137             'Tk::BrowseEntry'=> 'Tcl::pTk::BrowseEntry',
138             'Tk::Callback'=> 'Tcl::pTk::Callback',
139             'Tk::TableMatrix'=> 'Tcl::pTk::TableMatrix',
140             'Tk::Table'=> 'Tcl::pTk::Table',
141             'Tk::TableMatrix::Spreadsheet'=> 'Tcl::pTk::TableMatrix::Spreadsheet',
142             'Tk::TableMatrix::SpreadsheetHideRows'=> 'Tcl::pTk::TableMatrix::SpreadsheetHideRows',
143             };
144            
145             ######### End of Package Globals ###########
146             # Alias Packages
147             aliasPackages($packageAliases);
148              
149              
150              
151              
152              
153             sub TkHijack {
154             # When placed first on the INC path, this will allow us to hijack
155             # any requests for 'use Tk' and any Tk::* modules and replace them
156             # with our own stuff.
157             my ($coderef, $module) = @_; # $coderef is to myself
158             #print "TkHijack encoutering $module\n";
159             return undef unless $module =~ m!^Tk(/|\.pm$)!;
160            
161             #print "TkHijack $module\n";
162              
163             my ($package, $callerfile, $callerline) = caller;
164             #print "TkHijack package/callerFile/callerline = $package $callerfile $callerline\n";
165            
166             my $mapped = $translateList->{$module};
167            
168             if( defined($mapped) && !$mapped){ # Module exists in translateList, but no mapped file
169             my $fakefile;
170             open(my $fh, '<', \$fakefile) || die "oops"; # open a file "in-memory"
171            
172             $module =~ s!/!::!g;
173             $module =~ s/\.pm$//;
174            
175             # Make Version if importing Tk (needed for some scripts to work right)
176             my $versionText = "\n";
177             my $requireText = "\n"; # if Tk module, set export of Ev subs
178             if( $module eq 'Tk' ){
179            
180             $requireText = "use Exporter 'import';\n";
181             $requireText .= '@EXPORT_OK = (qw/ Ev catch/);'."\n";
182            
183             $versionText = '$Tk::VERSION = 805.001;'."\n";
184            
185             # Redefine common Tk subs/variables to Tcl::pTk equivalents
186             no warnings;
187             *Tk::MainLoop = \&Tcl::pTk::MainLoop;
188             *Tk::findINC = \&Tcl::pTk::findINC;
189             *Tk::after = \&Tcl::pTk::after;
190             *Tk::DoOneEvent = \&Tcl::pTk::DoOneEvent;
191             *Tk::Ev = \&Tcl::pTk::Ev;
192             *Tk::Exists = \&Tcl::pTk::Exists;
193             *Tk::break = \&Tcl::pTk::break;
194             *Tk::platform = \$Tcl::pTk::platform;
195             *Tk::timeofday = \&Tcl::pTk::timeofday;
196             *Tk::fileevent = \&Tcl::pTk::fileevent;
197             *Tk::bind = \&Tcl::pTk::Widget::bind;
198             *Tk::ACTIVE_BG = \&Tcl::pTk::ACTIVE_BG;
199             *Tk::NORMAL_BG = \&Tcl::pTk::NORMAL_BG;
200             *Tk::SELECT_BG = \&Tcl::pTk::SELECT_BG;
201            
202            
203             }
204            
205            
206             $fakefile = <
207             package $module;
208             $requireText
209             $versionText
210             #warn "### $callerfile:$callerline not really loading $module ###" if($Tcl::pTk::TkHijack::debug);
211             sub foo { 1; }
212             1;
213             EOS
214             return $fh;
215             }
216             elsif( defined($mapped) ){ # Module exists in translateList with a mapped file
217              
218             # Turn mapped file into name suitable for a 'use' statement
219             my $usefile = $mapped;
220             $usefile =~ s!/!::!g;
221             $usefile =~ s/\.pm$//;
222              
223             #warn "### $callerfile:$callerline loading Tcl Tk $usefile to substitute for $module ###" if($Tcl::pTk::TkHijack::debug);
224             # Turn mapped file into use statement
225             my $fakefile;
226             open(my $fh, '<', \$fakefile) || die "oops"; # open a file "in-memory"
227             $fakefile = <
228             use $usefile;
229             1;
230             EOS
231             return $fh;
232             }
233             else{
234             #warn("Warning No Tcl::pTk Equivalent to $module from $callerfile line $callerline, loading anyway...\n") if $debug;
235             }
236            
237             }
238              
239             ############## Sub To Alias Packages ########
240             sub aliasPackages{
241             my $aliases = shift;
242             my $aliasTo;
243             foreach my $aliasFrom ( keys %$aliases){
244             $aliasTo = $packageAliases->{$aliasFrom};
245             *{$aliasFrom.'::'} = *{$aliasTo.'::'};
246             }
247             }
248              
249              
250             ################### MainWindow package #################3
251             ## Created so the lines like the following work
252             ## my $mw = new MainWindow;
253             package MainWindow;
254              
255             sub new{
256             Tcl::pTk::MainWindow();
257             }
258              
259             1;