1## -*- mode: Tcl; coding: utf-8; -*-
2 # ###################################################################
3 #  TclAE - Functions for building AppleEvents
4 #  			(modernization of appleEvents.tcl)
5 #
6 #  FILE: "aebuild.tcl"
7 #                                    created: 12/13/99 {12:55:28 PM}
8 #                                last update: 7/25/04 {11:38:58 PM}
9 #                                    version: 2.0
10 #  Author: Jonathan Guyer
11 #  E-mail: jguyer@his.com
12 #    mail: Alpha Cabal
13 #          POMODORO no seisan
14 #     www: http://www.his.com/jguyer/
15 #
16 # ========================================================================
17 #               Copyright (c) 1999-2004 Jonathan Guyer
18 #                        All rights reserved
19 # ========================================================================
20 # Permission to use, copy, modify, and distribute this software and its
21 # documentation for any purpose and without fee is hereby granted,
22 # provided that the above copyright notice appear in all copies and that
23 # both that the copyright notice and warranty disclaimer appear in
24 # supporting documentation.
25 #
26 # Jonathan Guyer disclaims all warranties with regard to this software,
27 # including all implied warranties of merchantability and fitness.  In
28 # no event shall Jonathan Guyer be liable for any special, indirect or
29 # consequential damages or any damages whatsoever resulting from loss of
30 # use, data or profits, whether in an action of contract, negligence or
31 # other tortuous action, arising out of or in connection with the use or
32 # performance of this software.
33 # ========================================================================
34 #  Description:
35 #
36 #  History
37 #
38 #  modified   by  rev reason
39 #  ---------- --- --- -----------
40 #  1999-12-13 JEG 1.0 original
41 # ###################################################################
42 ##
43
44# ◊◊◊◊ Initialization ◊◊◊◊ #
45
46namespace eval tclAE::build {}
47
48# ◊◊◊◊ Event handling ◊◊◊◊ #
49
50##
51 # -------------------------------------------------------------------------
52 #
53 # "tclAE::build::throw" --
54 #
55 #  Shorthand routine to check for AppleEvent errors
56 # -------------------------------------------------------------------------
57 ##
58proc tclAE::build::throw {args} {
59	# Event is only parsed for error checking, so purge
60	# when done (in the event of an error, it'll already
61	# be gone).
62	eval tclAE::build::event $args
63	return
64}
65
66##
67 # -------------------------------------------------------------------------
68 #
69 # "tclAE::build::event" --
70 #
71 #  Encapsulation for new and old style event building.
72 #
73 # Results:
74 #  The parsed result of the event.
75 # -------------------------------------------------------------------------
76 ##
77proc tclAE::build::event {args} {
78    set event [eval tclAE::send -r $args]
79
80    # No error if these keywords are missing
81    if {[catch {tclAE::getKeyData $event "errn" "long"} errn]} {
82	set errn 0
83    }
84
85    if {[catch {tclAE::getKeyData $event "errs" "TEXT"} errs]} {
86	set errs ""
87    }
88
89    error::throwOSErr $errn $errs
90
91    return $event
92}
93
94##
95 # -------------------------------------------------------------------------
96 #
97 # "tclAE::build::resultDataAs" --
98 #
99 #  Shorthand routine to get the direct object result of an AEBuild call
100 # -------------------------------------------------------------------------
101 ##
102proc tclAE::build::resultDataAs {type args} {
103    global errorMsg
104
105    set result ""
106
107    set event [eval tclAE::build::event $args]
108
109    if {[catch {set result [tclAE::getKeyData $event ---- $type]} errorMsg]} {
110	if {![string match "Missing keyword '*' in record" $errorMsg]} {
111	    # No direct object is OK
112	    error::display
113	}
114    }
115
116    return $result
117}
118
119##
120 # -------------------------------------------------------------------------
121 #
122 # "tclAE::build::resultData" --
123 #
124 #  Shorthand routine to get the direct object result of an AEBuild call
125 # -------------------------------------------------------------------------
126 ##
127proc tclAE::build::resultData {args} {
128    return [eval tclAE::build::resultDataAs **** $args]
129}
130
131##
132 # -------------------------------------------------------------------------
133 #
134 # "tclAE::build::resultDescAs" --
135 #
136 #  Shorthand routine to get the direct object result of an AEBuild call,
137 #  coercing to $type
138 # -------------------------------------------------------------------------
139 ##
140proc tclAE::build::resultDescAs {type args} {
141    global errorMsg
142
143    set result ""
144
145    set event [eval tclAE::build::event $args]
146
147    if {[catch {set result [tclAE::getKeyDesc $event ---- $type]} errorMsg]} {
148	if {![string match "Missing keyword '*' in record" $errorMsg]} {
149	    # No direct object is OK
150	    error::display
151	}
152    }
153
154    return $result
155}
156
157##
158 # -------------------------------------------------------------------------
159 #
160 # "tclAE::build::resultDesc" --
161 #
162 #  Shorthand routine to get the direct object result of an AEBuild call,
163 #  retaining the type code
164 # -------------------------------------------------------------------------
165 ##
166proc tclAE::build::resultDesc {args} {
167    return [eval tclAE::build::resultDescAs **** $args]
168}
169
170##
171 # -------------------------------------------------------------------------
172 #
173 # "tclAE::build::protect" --
174 #
175 #  Alpha seems pickier about ident lengths than AEGizmos says it should be.
176 #  Protect any whitespace.
177 #
178 # Results:
179 #  Returns $value, possible bracketed with ' quotes
180 #
181 # Side effects:
182 #  None.
183 # -------------------------------------------------------------------------
184 ##
185proc tclAE::build::protect {value} {
186	set value [string trimright $value]
187	if {[regexp {[][ @‘'“”:,({})-]} $value blah]} {
188		set quote 1
189	} else {
190		set quote 0
191	}
192
193	set value [format "%-4.4s" $value]
194
195	if {$quote} {
196		set value "'${value}'"
197	}
198
199	return $value
200}
201
202proc tclAE::build::objectProperty {process property object} {
203	return [tclAE::build::resultData $process core getd ---- \
204				[tclAE::build::propertyObject $property $object]]
205}
206
207# ◊◊◊◊ Builders ◊◊◊◊ #
208
209proc tclAE::build::coercion {fromValue toType} {
210	set toType [tclAE::build::protect $toType]
211
212	switch -- [string index $fromValue 0] {
213		"\{" { # value is record
214			return "${toType}${fromValue}"
215		}
216		"\[" { # value is list
217			set msg "Cannot coerce a list"
218			error $msg "" [list AEParse 16 $msg]
219		}
220		default {
221			return "${toType}(${fromValue})"
222		}
223	}
224}
225
226##
227 # -------------------------------------------------------------------------
228 #
229 # "tclAE::build::List" --
230 #
231 #  Convert list 'l' to an AE list, i.e., "[l1, l2, l3, ...]".
232 #  "-as type" coerces elements to 'type' before joining.
233 #  Set "-untyped" if the elements do not consist of AEDescriptors
234 # -------------------------------------------------------------------------
235 ##
236proc tclAE::build::List {l args} {
237	set opts(-as) ""
238	set opts(-untyped) 0
239	getOpts as
240
241	if {[string length $opts(-as)] != 0} {
242		set out {}
243		foreach item $l {
244			lappend out [tclAE::build::$opts(-as) $item]
245		}
246	} elseif {!$opts(-untyped)} {
247		set out {}
248		foreach item $l {
249			lappend out $item
250		}
251	} else {
252		set out $l
253	}
254
255	set out [join $out ", "]
256	return "\[$out\]"
257}
258
259##
260 # -------------------------------------------------------------------------
261 #
262 # "tclAE::build::hexd" --
263 #
264 #  Convert 'value' to '«value»'.
265 #  value's spaces are stripped and it is left-padded with 0 to even digits.
266 # -------------------------------------------------------------------------
267 ##
268proc tclAE::build::hexd {value} {
269	set newval $value
270	if {[string length $newval] % 2} {
271		# left pad with zero to make even number of digits
272		set newval "0${newval}"
273	}
274	if {![regexp {^[0-9a-fA-F]+$} [string trim $newval]]} {
275	    if {[regexp "^\[ \t\r\n\]*$" $newval]} {
276		return ""
277	    } else {
278		set msg "Non-hex-digit in \u00ab${value}\u00bb"
279		error $msg "" [list AECoerce 6 $msg]
280	    }
281	} else {
282		return "\u00ab${newval}\u00bb"
283	}
284}
285
286##
287 # -------------------------------------------------------------------------
288 #
289 # "tclAE::build::bool" --
290 #
291 #  Convert 'val' to AE 'bool(«val»)'.
292 # -------------------------------------------------------------------------
293 ##
294proc tclAE::build::bool {val} {
295    if {$val} {
296	set val 1
297    } else {
298	set val 0
299    }
300
301    return [tclAE::build::coercion [tclAE::build::hexd $val] bool]
302}
303
304##
305 # -------------------------------------------------------------------------
306 #
307 # "tclAE::build::TEXT" --
308 #
309 #  Convert $txt to “TEXT”.
310 #  If there are curly quotes in $txt, output in raw hex, coerced to TEXT
311 # -------------------------------------------------------------------------
312 ##
313proc tclAE::build::TEXT {txt} {
314    if {$txt == ""} {
315	return "[tclAE::build::coercion {} TEXT]"
316    }
317    if {[regexp {[\u0000-\u001f\u201c\u201d\\]} $txt]} {
318	binary scan [encoding convertto macRoman $txt] H* hexd
319	return "[tclAE::build::coercion [tclAE::build::hexd $hexd] TEXT]"
320    }
321    return "\u201c${txt}\u201d"
322}
323
324##
325 # -------------------------------------------------------------------------
326 #
327 # "tclAE::build::alis" --
328 #
329 #  Convert 'path' to an alis(«...»).
330 # -------------------------------------------------------------------------
331 ##
332proc tclAE::build::alis {path} {
333    return [tclAE::coerceData utxt $path alis]
334}
335
336##
337 # -------------------------------------------------------------------------
338 #
339 # "tclAE::build::fss" --
340 #
341 #  Convert 'path' to an 'fss '(«...»).
342 # -------------------------------------------------------------------------
343 ##
344proc tclAE::build::fss {path} {
345    return [tclAE::coerceData TEXT $path fss]
346}
347
348##
349 # -------------------------------------------------------------------------
350 #
351 # "tclAE::build::path" --
352 #
353 #  Convert 'path' to an alis(«...») or a furl(“...”), depending on OS.
354 # -------------------------------------------------------------------------
355 ##
356proc tclAE::build::path {path} {
357    global tcl_platform
358
359    # For some inexplicable reason, Apple decided that aliases
360    # cannot refer to non-existent files on Mac OS X, so
361    # we create a CFURL instead
362    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
363	return "furl([tclAE::build::TEXT $path])"
364    } else {
365	return [tclAE::coerceData TEXT $path alis]
366    }
367}
368
369##
370 # -------------------------------------------------------------------------
371 #
372 # "tclAE::build::ident" --
373 #
374 #  Dummy proc for rebuilding AEGizmos strings from parsed lists
375 # -------------------------------------------------------------------------
376 ##
377proc tclAE::build::enum {enum} {
378    return [tclAE::build::protect $enum]
379}
380
381
382proc tclAE::build::name {name} {
383    return "form:'name', seld:[tclAE::build::TEXT $name]"
384}
385
386proc tclAE::build::filename {name} {
387    global tcl_platform
388    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
389	set name [tclAE::getHFSPath $name]
390    }
391    return "obj{want:type('file'), from:'null'(), [tclAE::build::name $name] } "
392}
393
394proc tclAE::build::winByName {name} {
395    return "obj{want:type('cwin'), from:'null'(), [tclAE::build::name $name]}"
396}
397
398proc tclAE::build::winByPos {absPos} {
399    return "obj{want:type('cwin'), from:'null'(), [tclAE::build::absPos $absPos]}"
400}
401
402proc tclAE::build::lineRange {absPos1 absPos2} {
403    set lineObj1 "obj{want:type('clin'), from:'ccnt'(), [tclAE::build::absPos $absPos1]}"
404    set lineObj2 "obj{want:type('clin'), from:'ccnt'(), [tclAE::build::absPos $absPos2]}"
405    return "form:'rang', seld:rang{star:$lineObj1, stop:$lineObj2}"
406}
407
408proc tclAE::build::charRange {absPos1 absPos2} {
409    set charObj1 "obj{want:type('cha '), from:'ccnt'(), [tclAE::build::absPos $absPos1]}"
410    set charObj2 "obj{want:type('cha '), from:'ccnt'(), [tclAE::build::absPos $absPos2]}"
411    return "form:'rang', seld:rang{star:$charObj1, stop:$charObj2}"
412}
413
414proc tclAE::build::absPos {posName} {
415    #
416    # Use '1' or 'first' to specify first position
417    # and '-1' or 'last' to specify last position.
418    #
419    if {$posName == "first"} {
420	set posName 1
421    } elseif {$posName == "last"} {
422	set posName -1
423    }
424    if {[regexp {^(\+|-)?[0-9]+$} [string trim $posName]]} {
425	return "form:indx, seld:long($posName)"
426    } else {
427	error "tclAE::build::absPos: bad argument"
428    }
429}
430
431proc tclAE::build::nullObject {} {
432    return "'null'()"
433}
434
435proc tclAE::build::objectType {type} {
436	return "type($type)"
437}
438
439proc tclAE::build::nameObject {type name {from ""}} 	{
440    if {$from == ""} {
441	set from [tclAE::build::nullObject]
442    }
443    return "obj \{ \
444      form:name, \
445      want:[tclAE::build::objectType $type], \
446      seld:$name, \
447      from:$from \
448    \}"
449}
450
451proc tclAE::build::indexObject {type ind {from ""}} {
452    if {$from == ""} {
453	set from [tclAE::build::nullObject]
454    }
455    return "obj \{ \
456      form:indx, \
457      want:[tclAE::build::objectType $type], \
458      seld:$ind, \
459      from:$from \
460    \}"
461}
462
463proc tclAE::build::everyObject {type {from ""}} {
464    return [tclAE::build::indexObject $type "abso('all ')" $from]
465}
466
467proc tclAE::build::rangeObject {type absPos1 absPos2 {from ""}} {
468    if {$from == ""} {
469	set from [tclAE::build::nullObject]
470    }
471    set type [tclAE::build::objectType $type]
472
473    set obj1 "obj{                      \
474	want:$type,                     \
475	from:'ccnt'(),                  \
476	[tclAE::build::absPos $absPos1] \
477    }"
478    set obj2 "obj{                      \
479	want:$type,                     \
480	from:'ccnt'(),                  \
481	[tclAE::build::absPos $absPos2] \
482    }"
483    return "obj {     \
484      form:rang,      \
485      want:$type,     \
486      seld:rang{      \
487	star:$obj1,   \
488	stop:$obj2    \
489      },              \
490      from:$from      \
491    }"
492}
493
494proc tclAE::build::propertyObject {prop {object ""}} {
495    if {[string length $object] == 0} {
496	set object [tclAE::build::nullObject]
497    }
498
499    return "obj \{\
500      form:prop, \
501      want:[tclAE::build::objectType prop], \
502      seld:[tclAE::build::objectType $prop], \
503      from:$object \
504    \}"
505}
506
507proc tclAE::build::propertyListObject {props {object ""}} {
508    if {[string length $object] == 0} {
509	set object [tclAE::build::nullObject]
510    }
511
512    return "obj \{\
513      form:prop, \
514      want:[tclAE::build::objectType prop], \
515      seld:[tclAE::build::List $props -as objectType], \
516      from:$object \
517    \}"
518}
519
520# ◊◊◊◊ Utilities ◊◊◊◊ #
521
522##
523 # -------------------------------------------------------------------------
524 #
525 # "tclAE::build::startupDisk" --
526 #
527 #  The name of the Startup Disk (as sometimes returned by the Finder)
528 # -------------------------------------------------------------------------
529 ##
530proc tclAE::build::startupDisk {} {
531    return [tclAE::build::objectProperty 'MACS' pnam \
532      "obj \{want:type(prop), from:'null'(), \
533      form:prop, seld:type(sdsk)\}" \
534    ]
535}
536
537##
538 # -------------------------------------------------------------------------
539 #
540 # "tclAE::build::userName" --
541 #
542 #  Return the default user name. The Mac's owner name,
543 #  which is in String Resource ID -16096, is inaccesible to Tcl
544 #  (at least until Tcl 8 is implemented).
545 #
546 #  Try different mechanisms for determining the user name.
547 #
548 # -------------------------------------------------------------------------
549 ##
550if {([info exists alpha::platform] && ${alpha::platform} != "alpha") ||
551	($tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin")} {
552    ;proc tclAE::build::userName {} {
553	global env
554
555	# better to use tcl_platform(user)?
556	return $env(USER)
557    }
558} else {
559    ;proc tclAE::build::userName {} {
560	return [text::fromPstring [resource read "STR " -16096]]
561    }
562}
563
564# Build a Folder object from its name
565proc tclAE::build::foldername {name} {
566    global tcl_platform
567    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
568	set name [tclAE::getHFSPath $name]
569    }
570    return "obj{want:type('cfol'), from:'null'(), [tclAE::build::name $name] } "
571}
572
573proc tclAE::build::kpid {{inPID ""}} {
574	if {$inPID eq ""} {
575		set inPID [pid]
576	}
577
578	if {$::tcl_platform(byteOrder) eq "bigEndian"} {
579		set binPID [binary format I $inPID]
580	} else {
581		set binPID [binary format i $inPID]
582	}
583	binary scan $binPID H* hexPID
584	return [tclAE::build::coercion [tclAE::build::hexd $hexPID] kpid]
585}