OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tk/] [mac/] [tclets.tcl] - Blame information for rev 1770

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
# tclets.tcl --
2
#
3
# Drag & Drop Tclets
4
# by Ray Johnson
5
#
6
# A simple way to create Tcl applications.  This applications will copy a droped Tcl file
7
# into a copy of a stub application (the user can pick).  The file is placed into the
8
# TEXT resource named "tclshrc" which is automatically executed on startup.
9
#
10
# RCS: @(#) $Id: tclets.tcl,v 1.1.1.1 2002-01-16 10:25:55 markom Exp $
11
#
12
# Copyright (c) 1997 Sun Microsystems, Inc.
13
#
14
# See the file "license.terms" for information on usage and redistribution
15
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16
#
17
 
18
# tkOpenDocument --
19
#
20
#       This procedure is a called whenever Wish recieves an "Open" event.  The
21
#       procedure must be named tkOpenDocument for this to work.  Passed in files
22
#       are assumed to be Tcl files that the user wants to be made into Tclets.
23
#       (Only the first one is used.)  The procedure then creates a copy of the
24
#       stub app and places the Tcl file in the new application's resource fork.
25
#
26
# Parameters:
27
#       args            List of files
28
#
29
# Results:
30
#       One success a new Tclet is created.
31
 
32
proc tkOpenDocument {args} {
33
    global droped_to_start
34
 
35
    # We only deal with the one file droped on the App
36
    set tclFile [lindex $args 0]
37
    set stub [GetStub]
38
 
39
    # Give a helper screen to guide user
40
    toplevel .helper -menu .bar
41
    unsupported1 style .helper dBoxProc
42
    message .helper.m -aspect 300 -text \
43
        "Select the name & location of your target Tcl application."
44
    pack .helper.m
45
    wm geometry .helper +20+40
46
    update idletasks
47
 
48
    # Get the target file from the end user
49
    set target [tk_getSaveFile]
50
    destroy .helper
51
    if {$target == ""} return
52
 
53
    # Copy stub, copy the droped file into the stubs text resource
54
    file copy $stub $target
55
    set id [open $tclFile r]
56
    set rid [resource open $target w]
57
    resource write -name tclshrc -file $rid TEXT [read $id]
58
    resource close $rid
59
    close $id
60
 
61
    # This is a hint to the start-up code - always set to true
62
    set droped_to_start true
63
}
64
 
65
# GetStub --
66
#
67
#       Get the location of our stub application.  The value may be cached,
68
#       in the preferences file, or we may need to ask the user.
69
#
70
# Parameters:
71
#       None.
72
#
73
# Results:
74
#       A path to the stub application.
75
 
76
proc GetStub {} {
77
    global env stub_location
78
 
79
    if {[info exists stub_location]} {
80
        return $stub_location
81
    }
82
 
83
    set file $env(PREF_FOLDER)
84
    append file "D&D Tclet Preferences"
85
 
86
 
87
    if {[file exists $file]} {
88
        uplevel #0 [list source $file]
89
        if {[info exists stub_location] && [file exists $stub_location]} {
90
            return $stub_location
91
        }
92
    }
93
 
94
    SelectStub
95
 
96
    if {[info exists stub_location]} {
97
        return $stub_location
98
    } else {
99
        exit
100
    }
101
}
102
 
103
# SelectStub --
104
#
105
#       This procedure uses tk_getOpenFile to allow the user to select
106
#       the copy of "Wish" that is used as the basis for Tclets.  The
107
#       result is stored in a preferences file.
108
#
109
# Parameters:
110
#       None.
111
#
112
# Results:
113
#       None.  The prefernce file is updated.
114
 
115
proc SelectStub {} {
116
    global env stub_location
117
 
118
    # Give a helper screen to guide user
119
    toplevel .helper -menu .bar
120
    unsupported1 style .helper dBoxProc
121
    message .helper.m -aspect 300 -text \
122
        "Select \"Wish\" stub to clone.  A copy of this application will be made to create your Tclet." \
123
 
124
    pack .helper.m
125
    wm geometry .helper +20+40
126
    update idletasks
127
 
128
    set new_location [tk_getOpenFile]
129
    destroy .helper
130
    if {$new_location != ""} {
131
        set stub_location $new_location
132
        set file [file join $env(PREF_FOLDER) "D&D Tclet Preferences"]
133
 
134
        set id [open $file w]
135
        puts $id [list set stub_location $stub_location]
136
        close $id
137
    }
138
}
139
 
140
# CreateMenus --
141
#
142
#       Create the menubar for this application.
143
#
144
# Parameters:
145
#       None.
146
#
147
# Results:
148
#       None.
149
 
150
proc CreateMenus {} {
151
    menu .bar
152
    .bar add cascade -menu .bar.file -label File
153
    .bar add cascade -menu .bar.apple
154
    . configure -menu .bar
155
 
156
    menu .bar.apple -tearoff 0
157
    .bar.apple add command -label "About Drag & Drop Tclets..." -command {ShowAbout}
158
 
159
    menu .bar.file -tearoff 0
160
    .bar.file add command -label "Show Console..." -command {console show}
161
    .bar.file add command -label "Select Wish Stub..." -command {SelectStub}
162
    .bar.file add separator
163
    .bar.file add command -label "Quit" -accel Command-Q -command exit
164
}
165
 
166
# ShowAbout --
167
#
168
#       Show the about box for Drag & Drop Tclets.
169
#
170
# Parameters:
171
#       None.
172
#
173
# Results:
174
#       None.
175
 
176
proc ShowAbout {} {
177
    tk_messageBox -icon info -type ok -message \
178
"Drag & Drop Tclets
179
by Ray Johnson\n\n\
180
Copyright (c) 1997 Sun Microsystems, Inc."
181
}
182
 
183
# Start --
184
#
185
#       This procedure provides the main start-up code for the application.
186
#       It should be run first thing on start up.  It will create the UI
187
#       and set up the rest of the state of the application.
188
#
189
# Parameters:
190
#       None.
191
#
192
# Results:
193
#       None.
194
 
195
proc Start {} {
196
    global droped_to_start
197
 
198
    # Hide . & console - see if we ran as a droped item
199
    wm geometry . 1x1-25000-25000
200
    console hide
201
 
202
    # Run update - if we get any drop events we know that we were
203
    # started by a drag & drop - if so, we quit automatically when done
204
    set droped_to_start false
205
    update
206
    if {$droped_to_start == "true"} {
207
        exit
208
    }
209
 
210
    # We were not started by a drag & drop - create the UI
211
    CreateMenus
212
}
213
 
214
# Now that everything is defined, lets start the app!
215
Start

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.