← Back to branch summary

~ubuntu-branches/ubuntu/gutsy/amsn/gutsy

« back to all changes in this revision

Viewing changes to plugins/tclAE2.0/Contents/Resources/aebuild.tcl

  • Committer: Bazaar Package Importer
  • Author(s): Theodore Karkoulis
  • Date: 2006-01-04 15:26:02 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20060104152602-ipe1yg00rl3nlklv
Tags: 0.95-1
http://bugs.debian.org/345052
http://bugs.debian.org/278575
New Upstream Release (closes: #345052, #278575).

Show diffs side-by-side

added added

removed removed

Lines of Context:
plugins/tclAE2.0/Contents/Resources/aebuild.tcl
1
 
## -*-Tcl-*-
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: 4/7/03 {11:37:39 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-2003 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
 
 
46
 
namespace 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
 
 ##
58
 
proc 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
 
        tclAE::disposeDesc [eval tclAE::build::event $args]
63
 
}
64
 
 
65
 
## 
66
 
 # -------------------------------------------------------------------------
67
 
 # 
68
 
 # "tclAE::build::event" --
69
 
 # 
70
 
 #  Encapsulation for new and old style event building.
71
 
 # 
72
 
 # Results:
73
 
 #  The parsed result of the event.
74
 
 # -------------------------------------------------------------------------
75
 
 ##
76
 
proc tclAE::build::event {args} {
77
 
    set event [eval tclAE::send -r $args]
78
 
    
79
 
    # No error if these keywords are missing
80
 
    if {[catch {tclAE::getKeyData $event "errn" "long"} errn]} {
81
 
        set errn 0
82
 
    }
83
 
 
84
 
    if {[catch {tclAE::getKeyData $event "errs" "TEXT"} errs]} {
85
 
        set errs ""
86
 
    }
87
 
    
88
 
    error::throwOSErr $errn $errs
89
 
    
90
 
    return $event
91
 
}
92
 
 
93
 
## 
94
 
 # -------------------------------------------------------------------------
95
 
 # 
96
 
 # "tclAE::build::resultDataAs" --
97
 
 # 
98
 
 #  Shorthand routine to get the direct object result of an AEBuild call
99
 
 # -------------------------------------------------------------------------
100
 
 ##
101
 
proc tclAE::build::resultDataAs {type args} {
102
 
    global errorMsg
103
 
    
104
 
    set result ""
105
 
    
106
 
    set event [eval tclAE::build::event $args]
107
 
    
108
 
    if {[catch {set result [tclAE::getKeyData $event ---- $type]} errorMsg]} {
109
 
        if {![string match "Missing keyword '*' in record" $errorMsg]} {
110
 
            # No direct object is OK
111
 
            error::display
112
 
        }               
113
 
    } 
114
 
    
115
 
    tclAE::disposeDesc $event
116
 
    
117
 
    return $result
118
 
}
119
 
 
120
 
## 
121
 
 # -------------------------------------------------------------------------
122
 
 # 
123
 
 # "tclAE::build::resultData" --
124
 
 # 
125
 
 #  Shorthand routine to get the direct object result of an AEBuild call
126
 
 # -------------------------------------------------------------------------
127
 
 ##
128
 
proc tclAE::build::resultData {args} {
129
 
    return [eval tclAE::build::resultDataAs **** $args]
130
 
}
131
 
 
132
 
## 
133
 
 # -------------------------------------------------------------------------
134
 
 # 
135
 
 # "tclAE::build::resultDescAs" --
136
 
 # 
137
 
 #  Shorthand routine to get the direct object result of an AEBuild call,
138
 
 #  coercing to $type
139
 
 # -------------------------------------------------------------------------
140
 
 ##
141
 
proc tclAE::build::resultDescAs {type args} {
142
 
    global errorMsg
143
 
    
144
 
    set result ""
145
 
    
146
 
    set event [eval tclAE::build::event $args]
147
 
    
148
 
    if {[catch {set result [tclAE::getKeyDesc $event ---- $type]} errorMsg]} {
149
 
        if {![string match "Missing keyword '*' in record" $errorMsg]} {
150
 
            # No direct object is OK
151
 
            error::display
152
 
        }               
153
 
    } 
154
 
    
155
 
    tclAE::disposeDesc $event
156
 
    
157
 
    return $result
158
 
}
159
 
 
160
 
## 
161
 
 # -------------------------------------------------------------------------
162
 
 # 
163
 
 # "tclAE::build::resultDesc" --
164
 
 # 
165
 
 #  Shorthand routine to get the direct object result of an AEBuild call,
166
 
 #  retaining the type code
167
 
 # -------------------------------------------------------------------------
168
 
 ##
169
 
proc tclAE::build::resultDesc {args} {
170
 
    return [eval tclAE::build::resultDescAs **** $args]
171
 
}
172
 
 
173
 
## 
174
 
 # -------------------------------------------------------------------------
175
 
 # 
176
 
 # "tclAE::build::protect" --
177
 
 # 
178
 
 #  Alpha seems pickier about ident lengths than AEGizmos says it should be. 
179
 
 #  Protect any whitespace.
180
 
 # 
181
 
 # Results:
182
 
 #  Returns $value, possible bracketed with ' quotes
183
 
 # 
184
 
 # Side effects:
185
 
 #  None.
186
 
 # -------------------------------------------------------------------------
187
 
 ##
188
 
proc tclAE::build::protect {value} {
189
 
        set value [string trimright $value]
190
 
        if {[regexp {[][ @‘'“”:,({})-]} $value blah]} {
191
 
                set quote 1
192
 
        } else {
193
 
                set quote 0
194
 
        }
195
 
        
196
 
        set value [format "%-4.4s" $value]
197
 
        
198
 
        if {$quote} {
199
 
                set value "'${value}'"          
200
 
        } 
201
 
        
202
 
        return $value
203
 
}
204
 
 
205
 
proc tclAE::build::objectProperty {process property object} {
206
 
        return [tclAE::build::resultData $process core getd ---- \
207
 
                                [tclAE::build::propertyObject $property $object]]
208
 
}
209
 
 
210
 
# ◊◊◊◊ Builders ◊◊◊◊ #
211
 
 
212
 
proc tclAE::build::coercion {fromValue toType} {
213
 
        set toType [tclAE::build::protect $toType]
214
 
 
215
 
        switch -- [string index $fromValue 0] {
216
 
                "\{" { # value is record
217
 
                        return "${toType}${fromValue}"
218
 
                }
219
 
                "\[" { # value is list
220
 
                        set msg "Cannot coerce a list"
221
 
                        error $msg "" [list AEParse 16 $msg]
222
 
                }
223
 
                default {
224
 
                        return "${toType}(${fromValue})"
225
 
                }
226
 
        }
227
 
}
228
 
 
229
 
## 
230
 
 # -------------------------------------------------------------------------
231
 
 # 
232
 
 # "tclAE::build::List" --
233
 
 # 
234
 
 #  Convert list 'l' to an AE list, i.e., "[l1, l2, l3, ...]".
235
 
 #  "-as type" coerces elements to 'type' before joining.  
236
 
 #  Set "-untyped" if the elements do not consist of AEDescriptors
237
 
 # -------------------------------------------------------------------------
238
 
 ##
239
 
proc tclAE::build::List {l args} {
240
 
        set opts(-as) ""
241
 
        set opts(-untyped) 0
242
 
        getOpts as
243
 
        
244
 
        if {[string length $opts(-as)] != 0} {
245
 
                set out {}
246
 
                foreach item $l {
247
 
                        lappend out [tclAE::build::$opts(-as) $item]
248
 
                }
249
 
        } elseif {!$opts(-untyped)} {
250
 
                set out {}
251
 
                foreach item $l {
252
 
                        lappend out $item
253
 
                }               
254
 
        } else {
255
 
                set out $l
256
 
        }
257
 
        
258
 
        set out [join $out ", "]
259
 
        return "\[$out\]"
260
 
}
261
 
 
262
 
## 
263
 
 # -------------------------------------------------------------------------
264
 
 # 
265
 
 # "tclAE::build::hexd" --
266
 
 # 
267
 
 #  Convert 'value' to '«value»'.
268
 
 #  value's spaces are stripped and it is left-padded with 0 to even digits.
269
 
 # -------------------------------------------------------------------------
270
 
 ##
271
 
proc tclAE::build::hexd {value} {
272
 
        set newval $value
273
 
        if {[string length $newval] % 2} {
274
 
                # left pad with zero to make even number of digits
275
 
                set newval "0${newval}"
276
 
        } 
277
 
        if {![is::Hexadecimal $newval]} {
278
 
            if {[is::Whitespace $newval]} {
279
 
                return ""
280
 
            } else {
281
 
                set msg "Non-hex-digit in \u00ab${value}\u00bb" 
282
 
                error $msg "" [list AECoerce 6 $msg]
283
 
            }
284
 
        } else {
285
 
                return "\u00ab${newval}\u00bb"
286
 
        }
287
 
}
288
 
 
289
 
## 
290
 
 # -------------------------------------------------------------------------
291
 
 # 
292
 
 # "tclAE::build::bool" --
293
 
 # 
294
 
 #  Convert 'val' to AE 'bool(«val»)'.
295
 
 # -------------------------------------------------------------------------
296
 
 ##
297
 
proc tclAE::build::bool {val} {
298
 
    if {$val} {
299
 
        set val 1
300
 
    } else {
301
 
        set val 0
302
 
    }
303
 
    
304
 
    return [tclAE::build::coercion [tclAE::build::hexd $val] bool]
305
 
}
306
 
 
307
 
## 
308
 
 # -------------------------------------------------------------------------
309
 
 # 
310
 
 # "tclAE::build::TEXT" --
311
 
 #  
312
 
 #  Convert $txt to “TEXT”.
313
 
 #  If there are curly quotes in $txt, output in raw hex, coerced to TEXT
314
 
 # -------------------------------------------------------------------------
315
 
 ##
316
 
proc tclAE::build::TEXT {txt} {
317
 
   if {$txt == ""} {
318
 
     return "[tclAE::build::coercion {} TEXT]"
319
 
   }
320
 
   if {[regexp {[\u0000-\u001f\u201c\u201d]} $txt]} {
321
 
     binary scan $txt H* hexd
322
 
     return "[tclAE::build::coercion [tclAE::build::hexd $hexd] TEXT]"
323
 
   }
324
 
   return "\u201c${txt}\u201d"
325
 
}
326
 
 
327
 
## 
328
 
 # -------------------------------------------------------------------------
329
 
 # 
330
 
 # "tclAE::build::alis" --
331
 
 # 
332
 
 #  Convert 'path' to an alis(«...»).
333
 
 # -------------------------------------------------------------------------
334
 
 ##
335
 
proc tclAE::build::alis {path} {
336
 
    return [tclAE::coerceData TEXT $path alis]
337
 
}
338
 
 
339
 
## 
340
 
 # -------------------------------------------------------------------------
341
 
 # 
342
 
 # "tclAE::build::fss" --
343
 
 # 
344
 
 #  Convert 'path' to an 'fss '(«...»).
345
 
 # -------------------------------------------------------------------------
346
 
 ##
347
 
proc tclAE::build::fss {path} {
348
 
    return [tclAE::coerceData TEXT $path fss]
349
 
}
350
 
 
351
 
## 
352
 
 # -------------------------------------------------------------------------
353
 
 # 
354
 
 # "tclAE::build::path" --
355
 
 # 
356
 
 #  Convert 'path' to an alis(«...») or a furl(“...”), depending on OS.
357
 
 # -------------------------------------------------------------------------
358
 
 ##
359
 
proc tclAE::build::path {path} {
360
 
    global tcl_platform
361
 
    
362
 
    # For some inexplicable reason, Apple decided that aliases
363
 
    # cannot refer to non-existent files on Mac OS X, so 
364
 
    # we create a CFURL instead
365
 
    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
366
 
        return "furl([tclAE::build::TEXT $path])"
367
 
    } else {
368
 
        return [tclAE::coerceData TEXT $path alis]
369
 
    }
370
 
}
371
 
 
372
 
## 
373
 
 # -------------------------------------------------------------------------
374
 
 # 
375
 
 # "tclAE::build::ident" --
376
 
 # 
377
 
 #  Dummy proc for rebuilding AEGizmos strings from parsed lists
378
 
 # -------------------------------------------------------------------------
379
 
 ##
380
 
proc tclAE::build::enum {enum} {
381
 
    return [tclAE::build::protect $enum]
382
 
}
383
 
 
384
 
 
385
 
proc tclAE::build::name {name} {
386
 
    return "form:'name', seld:[tclAE::build::TEXT $name]"
387
 
}
388
 
 
389
 
proc tclAE::build::filename {name} {
390
 
    global tcl_platform
391
 
    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
392
 
        set name [tclAE::getHFSPath $name]
393
 
    } 
394
 
    return "obj{want:type('file'), from:'null'(), [tclAE::build::name $name] } "
395
 
}
396
 
 
397
 
proc tclAE::build::winByName {name} {
398
 
    return "obj{want:type('cwin'), from:'null'(), [tclAE::build::name $name]}"
399
 
}
400
 
 
401
 
proc tclAE::build::winByPos {absPos} {
402
 
    return "obj{want:type('cwin'), from:'null'(), [tclAE::build::absPos $absPos]}"
403
 
}
404
 
 
405
 
proc tclAE::build::lineRange {absPos1 absPos2} {
406
 
    set lineObj1 "obj{want:type('clin'), from:'ccnt'(), [tclAE::build::absPos $absPos1]}"
407
 
    set lineObj2 "obj{want:type('clin'), from:'ccnt'(), [tclAE::build::absPos $absPos2]}"
408
 
    return "form:'rang', seld:rang{star:$lineObj1, stop:$lineObj2}"
409
 
}
410
 
 
411
 
proc tclAE::build::charRange {absPos1 absPos2} {
412
 
    set charObj1 "obj{want:type('cha '), from:'ccnt'(), [tclAE::build::absPos $absPos1]}"
413
 
    set charObj2 "obj{want:type('cha '), from:'ccnt'(), [tclAE::build::absPos $absPos2]}"
414
 
    return "form:'rang', seld:rang{star:$charObj1, stop:$charObj2}"
415
 
}
416
 
 
417
 
proc tclAE::build::absPos {posName} {
418
 
    #
419
 
    # Use '1' or 'first' to specify first position
420
 
    # and '-1' or 'last' to specify last position.
421
 
    #
422
 
    if {$posName == "first"} { 
423
 
        set posName 1 
424
 
    } elseif {$posName == "last"} { 
425
 
        set posName -1 
426
 
    }
427
 
    if {[is::Integer $posName]} {
428
 
        return "form:indx, seld:long($posName)"
429
 
    } else {
430
 
        error "tclAE::build::absPos: bad argument"
431
 
    }
432
 
}
433
 
 
434
 
proc tclAE::build::nullObject {} { 
435
 
    return "'null'()" 
436
 
}
437
 
 
438
 
proc tclAE::build::objectType {type} { 
439
 
        return "type($type)" 
440
 
}
441
 
 
442
 
proc tclAE::build::nameObject {type name {from ""}}     {
443
 
    if {$from == ""} {
444
 
        set from [tclAE::build::nullObject]
445
 
    } 
446
 
    return "obj \{ \
447
 
      form:name, \
448
 
      want:[tclAE::build::objectType $type], \
449
 
      seld:$name, \
450
 
      from:$from \
451
 
    \}" 
452
 
}
453
 
 
454
 
proc tclAE::build::indexObject {type ind {from ""}} {
455
 
    if {$from == ""} {
456
 
        set from [tclAE::build::nullObject]
457
 
    } 
458
 
    return "obj \{ \
459
 
      form:indx, \
460
 
      want:[tclAE::build::objectType $type], \
461
 
      seld:$ind, \
462
 
      from:$from \
463
 
    \}" 
464
 
}
465
 
 
466
 
proc tclAE::build::everyObject {type {from ""}} {
467
 
    return [tclAE::build::indexObject $type "abso('all ')" $from]
468
 
}
469
 
 
470
 
proc tclAE::build::rangeObject {type absPos1 absPos2 {from ""}} {
471
 
    if {$from == ""} {
472
 
        set from [tclAE::build::nullObject]
473
 
    } 
474
 
    set type [tclAE::build::objectType $type]
475
 
    
476
 
    set obj1 "obj{                      \
477
 
        want:$type,                     \
478
 
        from:'ccnt'(),                  \
479
 
        [tclAE::build::absPos $absPos1] \
480
 
    }"
481
 
    set obj2 "obj{                      \
482
 
        want:$type,                     \
483
 
        from:'ccnt'(),                  \
484
 
        [tclAE::build::absPos $absPos2] \
485
 
    }"
486
 
    return "obj {     \
487
 
      form:rang,      \
488
 
      want:$type,     \
489
 
      seld:rang{      \
490
 
        star:$obj1,   \
491
 
        stop:$obj2    \
492
 
      },              \
493
 
      from:$from      \
494
 
    }" 
495
 
}
496
 
 
497
 
proc tclAE::build::propertyObject {prop {object ""}} { 
498
 
    if {[string length $object] == 0} {
499
 
        set object [tclAE::build::nullObject]
500
 
    } 
501
 
    
502
 
    return "obj \{\
503
 
      form:prop, \
504
 
      want:[tclAE::build::objectType prop], \
505
 
      seld:[tclAE::build::objectType $prop], \
506
 
      from:$object \
507
 
    \}" 
508
 
}
509
 
 
510
 
proc tclAE::build::propertyListObject {props {object ""}} { 
511
 
    if {[string length $object] == 0} {
512
 
        set object [tclAE::build::nullObject]
513
 
    } 
514
 
    
515
 
    return "obj \{\
516
 
      form:prop, \
517
 
      want:[tclAE::build::objectType prop], \
518
 
      seld:[tclAE::build::List $props -as objectType], \
519
 
      from:$object \
520
 
    \}" 
521
 
}
522
 
 
523
 
# ◊◊◊◊ Utilities ◊◊◊◊ #
524
 
 
525
 
## 
526
 
 # -------------------------------------------------------------------------
527
 
 # 
528
 
 # "tclAE::build::startupDisk" --
529
 
 # 
530
 
 #  The name of the Startup Disk (as sometimes returned by the Finder)
531
 
 # -------------------------------------------------------------------------
532
 
 ##
533
 
proc tclAE::build::startupDisk {} {
534
 
    return [tclAE::build::objectProperty 'MACS' pnam \
535
 
      "obj \{want:type(prop), from:'null'(), \
536
 
      form:prop, seld:type(sdsk)\}" \
537
 
    ]   
538
 
}
539
 
 
540
 
## 
541
 
 # -------------------------------------------------------------------------
542
 
 # 
543
 
 # "tclAE::build::userName" --
544
 
 # 
545
 
 #  Return the default user name. The Mac's owner name,
546
 
 #  which is in String Resource ID -16096, is inaccesible to Tcl 
547
 
 #  (at least until Tcl 8 is implemented).
548
 
 #  
549
 
 #  Try different mechanisms for determining the user name.
550
 
 #  
551
 
 # -------------------------------------------------------------------------
552
 
 ##
553
 
if {([info exists alpha::platform] && ${alpha::platform} != "alpha") || 
554
 
        ($tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin")} {
555
 
    ;proc tclAE::build::userName {} {
556
 
        global env
557
 
        
558
 
        # better to use tcl_platform(user)?
559
 
        return $env(USER)
560
 
    }
561
 
} else {
562
 
    ;proc tclAE::build::userName {} {
563
 
        return [text::fromPstring [resource read "STR " -16096]]
564
 
    }
565
 
}    
566
 
 
567
 
# Build a Folder object from its name
568
 
proc tclAE::build::foldername {name} {
569
 
    global tcl_platform
570
 
    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
571
 
        set name [tclAE::getHFSPath $name]
572
 
    } 
573
 
    return "obj{want:type('cfol'), from:'null'(), [tclAE::build::name $name] } "
574
 
}
575
 
## -*-Tcl-*-
576
 
 # ###################################################################
577
 
 #  TclAE - Functions for building AppleEvents 
578
 
 #                      (modernization of appleEvents.tcl)
579
 
 # 
580
 
 #  FILE: "aebuild.tcl"
581
 
 #                                    created: 12/13/99 {12:55:28 PM} 
582
 
 #                                last update: 4/7/03 {11:37:39 PM} 
583
 
 #                                    version: 2.0
584
 
 #  Author: Jonathan Guyer
585
 
 #  E-mail: jguyer@his.com
586
 
 #    mail: Alpha Cabal
587
 
 #          POMODORO no seisan
588
 
 #     www: http://www.his.com/jguyer/
589
 
 #  
590
 
 # ========================================================================
591
 
 #               Copyright (c) 1999-2003 Jonathan Guyer
592
 
 #                        All rights reserved
593
 
 # ========================================================================
594
 
 # Permission to use, copy, modify, and distribute this software and its
595
 
 # documentation for any purpose and without fee is hereby granted,
596
 
 # provided that the above copyright notice appear in all copies and that
597
 
 # both that the copyright notice and warranty disclaimer appear in
598
 
 # supporting documentation.
599
 
 # 
600
 
 # Jonathan Guyer disclaims all warranties with regard to this software,
601
 
 # including all implied warranties of merchantability and fitness.  In
602
 
 # no event shall Jonathan Guyer be liable for any special, indirect or
603
 
 # consequential damages or any damages whatsoever resulting from loss of
604
 
 # use, data or profits, whether in an action of contract, negligence or
605
 
 # other tortuous action, arising out of or in connection with the use or
606
 
 # performance of this software.
607
 
 # ========================================================================
608
 
 #  Description: 
609
 
 # 
610
 
 #  History
611
 
 # 
612
 
 #  modified   by  rev reason
613
 
 #  ---------- --- --- -----------
614
 
 #  1999-12-13 JEG 1.0 original
615
 
 # ###################################################################
616
 
 ##
617
 
 
618
 
# ◊◊◊◊ Initialization ◊◊◊◊ #
619
 
 
620
 
namespace eval tclAE::build {}
621
 
 
622
 
# ◊◊◊◊ Event handling ◊◊◊◊ #
623
 
 
624
 
## 
625
 
 # -------------------------------------------------------------------------
626
 
 # 
627
 
 # "tclAE::build::throw" --
628
 
 # 
629
 
 #  Shorthand routine to check for AppleEvent errors
630
 
 # -------------------------------------------------------------------------
631
 
 ##
632
 
proc tclAE::build::throw {args} {
633
 
        # Event is only parsed for error checking, so purge
634
 
        # when done (in the event of an error, it'll already
635
 
        # be gone).
636
 
        tclAE::disposeDesc [eval tclAE::build::event $args]
637
 
}
638
 
 
639
 
## 
640
 
 # -------------------------------------------------------------------------
641
 
 # 
642
 
 # "tclAE::build::event" --
643
 
 # 
644
 
 #  Encapsulation for new and old style event building.
645
 
 # 
646
 
 # Results:
647
 
 #  The parsed result of the event.
648
 
 # -------------------------------------------------------------------------
649
 
 ##
650
 
proc tclAE::build::event {args} {
651
 
    set event [eval tclAE::send -r $args]
652
 
    
653
 
    # No error if these keywords are missing
654
 
    if {[catch {tclAE::getKeyData $event "errn" "long"} errn]} {
655
 
        set errn 0
656
 
    }
657
 
 
658
 
    if {[catch {tclAE::getKeyData $event "errs" "TEXT"} errs]} {
659
 
        set errs ""
660
 
    }
661
 
    
662
 
    error::throwOSErr $errn $errs
663
 
    
664
 
    return $event
665
 
}
666
 
 
667
 
## 
668
 
 # -------------------------------------------------------------------------
669
 
 # 
670
 
 # "tclAE::build::resultDataAs" --
671
 
 # 
672
 
 #  Shorthand routine to get the direct object result of an AEBuild call
673
 
 # -------------------------------------------------------------------------
674
 
 ##
675
 
proc tclAE::build::resultDataAs {type args} {
676
 
    global errorMsg
677
 
    
678
 
    set result ""
679
 
    
680
 
    set event [eval tclAE::build::event $args]
681
 
    
682
 
    if {[catch {set result [tclAE::getKeyData $event ---- $type]} errorMsg]} {
683
 
        if {![string match "Missing keyword '*' in record" $errorMsg]} {
684
 
            # No direct object is OK
685
 
            error::display
686
 
        }               
687
 
    } 
688
 
    
689
 
    tclAE::disposeDesc $event
690
 
    
691
 
    return $result
692
 
}
693
 
 
694
 
## 
695
 
 # -------------------------------------------------------------------------
696
 
 # 
697
 
 # "tclAE::build::resultData" --
698
 
 # 
699
 
 #  Shorthand routine to get the direct object result of an AEBuild call
700
 
 # -------------------------------------------------------------------------
701
 
 ##
702
 
proc tclAE::build::resultData {args} {
703
 
    return [eval tclAE::build::resultDataAs **** $args]
704
 
}
705
 
 
706
 
## 
707
 
 # -------------------------------------------------------------------------
708
 
 # 
709
 
 # "tclAE::build::resultDescAs" --
710
 
 # 
711
 
 #  Shorthand routine to get the direct object result of an AEBuild call,
712
 
 #  coercing to $type
713
 
 # -------------------------------------------------------------------------
714
 
 ##
715
 
proc tclAE::build::resultDescAs {type args} {
716
 
    global errorMsg
717
 
    
718
 
    set result ""
719
 
    
720
 
    set event [eval tclAE::build::event $args]
721
 
    
722
 
    if {[catch {set result [tclAE::getKeyDesc $event ---- $type]} errorMsg]} {
723
 
        if {![string match "Missing keyword '*' in record" $errorMsg]} {
724
 
            # No direct object is OK
725
 
            error::display
726
 
        }               
727
 
    } 
728
 
    
729
 
    tclAE::disposeDesc $event
730
 
    
731
 
    return $result
732
 
}
733
 
 
734
 
## 
735
 
 # -------------------------------------------------------------------------
736
 
 # 
737
 
 # "tclAE::build::resultDesc" --
738
 
 # 
739
 
 #  Shorthand routine to get the direct object result of an AEBuild call,
740
 
 #  retaining the type code
741
 
 # -------------------------------------------------------------------------
742
 
 ##
743
 
proc tclAE::build::resultDesc {args} {
744
 
    return [eval tclAE::build::resultDescAs **** $args]
745
 
}
746
 
 
747
 
## 
748
 
 # -------------------------------------------------------------------------
749
 
 # 
750
 
 # "tclAE::build::protect" --
751
 
 # 
752
 
 #  Alpha seems pickier about ident lengths than AEGizmos says it should be. 
753
 
 #  Protect any whitespace.
754
 
 # 
755
 
 # Results:
756
 
 #  Returns $value, possible bracketed with ' quotes
757
 
 # 
758
 
 # Side effects:
759
 
 #  None.
760
 
 # -------------------------------------------------------------------------
761
 
 ##
762
 
proc tclAE::build::protect {value} {
763
 
        set value [string trimright $value]
764
 
        if {[regexp {[][ @‘'“”:,({})-]} $value blah]} {
765
 
                set quote 1
766
 
        } else {
767
 
                set quote 0
768
 
        }
769
 
        
770
 
        set value [format "%-4.4s" $value]
771
 
        
772
 
        if {$quote} {
773
 
                set value "'${value}'"          
774
 
        } 
775
 
        
776
 
        return $value
777
 
}
778
 
 
779
 
proc tclAE::build::objectProperty {process property object} {
780
 
        return [tclAE::build::resultData $process core getd ---- \
781
 
                                [tclAE::build::propertyObject $property $object]]
782
 
}
783
 
 
784
 
# ◊◊◊◊ Builders ◊◊◊◊ #
785
 
 
786
 
proc tclAE::build::coercion {fromValue toType} {
787
 
        set toType [tclAE::build::protect $toType]
788
 
 
789
 
        switch -- [string index $fromValue 0] {
790
 
                "\{" { # value is record
791
 
                        return "${toType}${fromValue}"
792
 
                }
793
 
                "\[" { # value is list
794
 
                        set msg "Cannot coerce a list"
795
 
                        error $msg "" [list AEParse 16 $msg]
796
 
                }
797
 
                default {
798
 
                        return "${toType}(${fromValue})"
799
 
                }
800
 
        }
801
 
}
802
 
 
803
 
## 
804
 
 # -------------------------------------------------------------------------
805
 
 # 
806
 
 # "tclAE::build::List" --
807
 
 # 
808
 
 #  Convert list 'l' to an AE list, i.e., "[l1, l2, l3, ...]".
809
 
 #  "-as type" coerces elements to 'type' before joining.  
810
 
 #  Set "-untyped" if the elements do not consist of AEDescriptors
811
 
 # -------------------------------------------------------------------------
812
 
 ##
813
 
proc tclAE::build::List {l args} {
814
 
        set opts(-as) ""
815
 
        set opts(-untyped) 0
816
 
        getOpts as
817
 
        
818
 
        if {[string length $opts(-as)] != 0} {
819
 
                set out {}
820
 
                foreach item $l {
821
 
                        lappend out [tclAE::build::$opts(-as) $item]
822
 
                }
823
 
        } elseif {!$opts(-untyped)} {
824
 
                set out {}
825
 
                foreach item $l {
826
 
                        lappend out $item
827
 
                }               
828
 
        } else {
829
 
                set out $l
830
 
        }
831
 
        
832
 
        set out [join $out ", "]
833
 
        return "\[$out\]"
834
 
}
835
 
 
836
 
## 
837
 
 # -------------------------------------------------------------------------
838
 
 # 
839
 
 # "tclAE::build::hexd" --
840
 
 # 
841
 
 #  Convert 'value' to '«value»'.
842
 
 #  value's spaces are stripped and it is left-padded with 0 to even digits.
843
 
 # -------------------------------------------------------------------------
844
 
 ##
845
 
proc tclAE::build::hexd {value} {
846
 
        set newval $value
847
 
        if {[string length $newval] % 2} {
848
 
                # left pad with zero to make even number of digits
849
 
                set newval "0${newval}"
850
 
        } 
851
 
        if {![is::Hexadecimal $newval]} {
852
 
            if {[is::Whitespace $newval]} {
853
 
                return ""
854
 
            } else {
855
 
                set msg "Non-hex-digit in \u00ab${value}\u00bb" 
856
 
                error $msg "" [list AECoerce 6 $msg]
857
 
            }
858
 
        } else {
859
 
                return "\u00ab${newval}\u00bb"
860
 
        }
861
 
}
862
 
 
863
 
## 
864
 
 # -------------------------------------------------------------------------
865
 
 # 
866
 
 # "tclAE::build::bool" --
867
 
 # 
868
 
 #  Convert 'val' to AE 'bool(«val»)'.
869
 
 # -------------------------------------------------------------------------
870
 
 ##
871
 
proc tclAE::build::bool {val} {
872
 
    if {$val} {
873
 
        set val 1
874
 
    } else {
875
 
        set val 0
876
 
    }
877
 
    
878
 
    return [tclAE::build::coercion [tclAE::build::hexd $val] bool]
879
 
}
880
 
 
881
 
## 
882
 
 # -------------------------------------------------------------------------
883
 
 # 
884
 
 # "tclAE::build::TEXT" --
885
 
 #  
886
 
 #  Convert $txt to “TEXT”.
887
 
 #  If there are curly quotes in $txt, output in raw hex, coerced to TEXT
888
 
 # -------------------------------------------------------------------------
889
 
 ##
890
 
proc tclAE::build::TEXT {txt} {
891
 
   if {$txt == ""} {
892
 
     return "[tclAE::build::coercion {} TEXT]"
893
 
   }
894
 
   if {[regexp {[\u0000-\u001f\u201c\u201d]} $txt]} {
895
 
     binary scan $txt H* hexd
896
 
     return "[tclAE::build::coercion [tclAE::build::hexd $hexd] TEXT]"
897
 
   }
898
 
   return "\u201c${txt}\u201d"
899
 
}
900
 
 
901
 
## 
902
 
 # -------------------------------------------------------------------------
903
 
 # 
904
 
 # "tclAE::build::alis" --
905
 
 # 
906
 
 #  Convert 'path' to an alis(«...»).
907
 
 # -------------------------------------------------------------------------
908
 
 ##
909
 
proc tclAE::build::alis {path} {
910
 
    return [tclAE::coerceData TEXT $path alis]
911
 
}
912
 
 
913
 
## 
914
 
 # -------------------------------------------------------------------------
915
 
 # 
916
 
 # "tclAE::build::fss" --
917
 
 # 
918
 
 #  Convert 'path' to an 'fss '(«...»).
919
 
 # -------------------------------------------------------------------------
920
 
 ##
921
 
proc tclAE::build::fss {path} {
922
 
    return [tclAE::coerceData TEXT $path fss]
923
 
}
924
 
 
925
 
## 
926
 
 # -------------------------------------------------------------------------
927
 
 # 
928
 
 # "tclAE::build::path" --
929
 
 # 
930
 
 #  Convert 'path' to an alis(«...») or a furl(“...”), depending on OS.
931
 
 # -------------------------------------------------------------------------
932
 
 ##
933
 
proc tclAE::build::path {path} {
934
 
    global tcl_platform
935
 
    
936
 
    # For some inexplicable reason, Apple decided that aliases
937
 
    # cannot refer to non-existent files on Mac OS X, so 
938
 
    # we create a CFURL instead
939
 
    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
940
 
        return "furl([tclAE::build::TEXT $path])"
941
 
    } else {
942
 
        return [tclAE::coerceData TEXT $path alis]
943
 
    }
944
 
}
945
 
 
946
 
## 
947
 
 # -------------------------------------------------------------------------
948
 
 # 
949
 
 # "tclAE::build::ident" --
950
 
 # 
951
 
 #  Dummy proc for rebuilding AEGizmos strings from parsed lists
952
 
 # -------------------------------------------------------------------------
953
 
 ##
954
 
proc tclAE::build::enum {enum} {
955
 
    return [tclAE::build::protect $enum]
956
 
}
957
 
 
958
 
 
959
 
proc tclAE::build::name {name} {
960
 
    return "form:'name', seld:[tclAE::build::TEXT $name]"
961
 
}
962
 
 
963
 
proc tclAE::build::filename {name} {
964
 
    global tcl_platform
965
 
    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
966
 
        set name [tclAE::getHFSPath $name]
967
 
    } 
968
 
    return "obj{want:type('file'), from:'null'(), [tclAE::build::name $name] } "
969
 
}
970
 
 
971
 
proc tclAE::build::winByName {name} {
972
 
    return "obj{want:type('cwin'), from:'null'(), [tclAE::build::name $name]}"
973
 
}
974
 
 
975
 
proc tclAE::build::winByPos {absPos} {
976
 
    return "obj{want:type('cwin'), from:'null'(), [tclAE::build::absPos $absPos]}"
977
 
}
978
 
 
979
 
proc tclAE::build::lineRange {absPos1 absPos2} {
980
 
    set lineObj1 "obj{want:type('clin'), from:'ccnt'(), [tclAE::build::absPos $absPos1]}"
981
 
    set lineObj2 "obj{want:type('clin'), from:'ccnt'(), [tclAE::build::absPos $absPos2]}"
982
 
    return "form:'rang', seld:rang{star:$lineObj1, stop:$lineObj2}"
983
 
}
984
 
 
985
 
proc tclAE::build::charRange {absPos1 absPos2} {
986
 
    set charObj1 "obj{want:type('cha '), from:'ccnt'(), [tclAE::build::absPos $absPos1]}"
987
 
    set charObj2 "obj{want:type('cha '), from:'ccnt'(), [tclAE::build::absPos $absPos2]}"
988
 
    return "form:'rang', seld:rang{star:$charObj1, stop:$charObj2}"
989
 
}
990
 
 
991
 
proc tclAE::build::absPos {posName} {
992
 
    #
993
 
    # Use '1' or 'first' to specify first position
994
 
    # and '-1' or 'last' to specify last position.
995
 
    #
996
 
    if {$posName == "first"} { 
997
 
        set posName 1 
998
 
    } elseif {$posName == "last"} { 
999
 
        set posName -1 
1000
 
    }
1001
 
    if {[is::Integer $posName]} {
1002
 
        return "form:indx, seld:long($posName)"
1003
 
    } else {
1004
 
        error "tclAE::build::absPos: bad argument"
1005
 
    }
1006
 
}
1007
 
 
1008
 
proc tclAE::build::nullObject {} { 
1009
 
    return "'null'()" 
1010
 
}
1011
 
 
1012
 
proc tclAE::build::objectType {type} { 
1013
 
        return "type($type)" 
1014
 
}
1015
 
 
1016
 
proc tclAE::build::nameObject {type name {from ""}}     {
1017
 
    if {$from == ""} {
1018
 
        set from [tclAE::build::nullObject]
1019
 
    } 
1020
 
    return "obj \{ \
1021
 
      form:name, \
1022
 
      want:[tclAE::build::objectType $type], \
1023
 
      seld:$name, \
1024
 
      from:$from \
1025
 
    \}" 
1026
 
}
1027
 
 
1028
 
proc tclAE::build::indexObject {type ind {from ""}} {
1029
 
    if {$from == ""} {
1030
 
        set from [tclAE::build::nullObject]
1031
 
    } 
1032
 
    return "obj \{ \
1033
 
      form:indx, \
1034
 
      want:[tclAE::build::objectType $type], \
1035
 
      seld:$ind, \
1036
 
      from:$from \
1037
 
    \}" 
1038
 
}
1039
 
 
1040
 
proc tclAE::build::everyObject {type {from ""}} {
1041
 
    return [tclAE::build::indexObject $type "abso('all ')" $from]
1042
 
}
1043
 
 
1044
 
proc tclAE::build::rangeObject {type absPos1 absPos2 {from ""}} {
1045
 
    if {$from == ""} {
1046
 
        set from [tclAE::build::nullObject]
1047
 
    } 
1048
 
    set type [tclAE::build::objectType $type]
1049
 
    
1050
 
    set obj1 "obj{                      \
1051
 
        want:$type,                     \
1052
 
        from:'ccnt'(),                  \
1053
 
        [tclAE::build::absPos $absPos1] \
1054
 
    }"
1055
 
    set obj2 "obj{                      \
1056
 
        want:$type,                     \
1057
 
        from:'ccnt'(),                  \
1058
 
        [tclAE::build::absPos $absPos2] \
1059
 
    }"
1060
 
    return "obj {     \
1061
 
      form:rang,      \
1062
 
      want:$type,     \
1063
 
      seld:rang{      \
1064
 
        star:$obj1,   \
1065
 
        stop:$obj2    \
1066
 
      },              \
1067
 
      from:$from      \
1068
 
    }" 
1069
 
}
1070
 
 
1071
 
proc tclAE::build::propertyObject {prop {object ""}} { 
1072
 
    if {[string length $object] == 0} {
1073
 
        set object [tclAE::build::nullObject]
1074
 
    } 
1075
 
    
1076
 
    return "obj \{\
1077
 
      form:prop, \
1078
 
      want:[tclAE::build::objectType prop], \
1079
 
      seld:[tclAE::build::objectType $prop], \
1080
 
      from:$object \
1081
 
    \}" 
1082
 
}
1083
 
 
1084
 
proc tclAE::build::propertyListObject {props {object ""}} { 
1085
 
    if {[string length $object] == 0} {
1086
 
        set object [tclAE::build::nullObject]
1087
 
    } 
1088
 
    
1089
 
    return "obj \{\
1090
 
      form:prop, \
1091
 
      want:[tclAE::build::objectType prop], \
1092
 
      seld:[tclAE::build::List $props -as objectType], \
1093
 
      from:$object \
1094
 
    \}" 
1095
 
}
1096
 
 
1097
 
# ◊◊◊◊ Utilities ◊◊◊◊ #
1098
 
 
1099
 
## 
1100
 
 # -------------------------------------------------------------------------
1101
 
 # 
1102
 
 # "tclAE::build::startupDisk" --
1103
 
 # 
1104
 
 #  The name of the Startup Disk (as sometimes returned by the Finder)
1105
 
 # -------------------------------------------------------------------------
1106
 
 ##
1107
 
proc tclAE::build::startupDisk {} {
1108
 
    return [tclAE::build::objectProperty 'MACS' pnam \
1109
 
      "obj \{want:type(prop), from:'null'(), \
1110
 
      form:prop, seld:type(sdsk)\}" \
1111
 
    ]   
1112
 
}
1113
 
 
1114
 
## 
1115
 
 # -------------------------------------------------------------------------
1116
 
 # 
1117
 
 # "tclAE::build::userName" --
1118
 
 # 
1119
 
 #  Return the default user name. The Mac's owner name,
1120
 
 #  which is in String Resource ID -16096, is inaccesible to Tcl 
1121
 
 #  (at least until Tcl 8 is implemented).
1122
 
 #  
1123
 
 #  Try different mechanisms for determining the user name.
1124
 
 #  
1125
 
 # -------------------------------------------------------------------------
1126
 
 ##
1127
 
if {([info exists alpha::platform] && ${alpha::platform} != "alpha") || 
1128
 
        ($tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin")} {
1129
 
    ;proc tclAE::build::userName {} {
1130
 
        global env
1131
 
        
1132
 
        # better to use tcl_platform(user)?
1133
 
        return $env(USER)
1134
 
    }
1135
 
} else {
1136
 
    ;proc tclAE::build::userName {} {
1137
 
        return [text::fromPstring [resource read "STR " -16096]]
1138
 
    }
1139
 
}    
1140
 
 
1141
 
# Build a Folder object from its name
1142
 
proc tclAE::build::foldername {name} {
1143
 
    global tcl_platform
1144
 
    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
1145
 
        set name [tclAE::getHFSPath $name]
1146
 
    } 
1147
 
    return "obj{want:type('cfol'), from:'null'(), [tclAE::build::name $name] } "
1148
 
}
1149
 
## -*-Tcl-*-
1150
 
 # ###################################################################
1151
 
 #  TclAE - Functions for building AppleEvents 
1152
 
 #                      (modernization of appleEvents.tcl)
1153
 
 # 
1154
 
 #  FILE: "aebuild.tcl"
1155
 
 #                                    created: 12/13/99 {12:55:28 PM} 
1156
 
 #                                last update: 4/7/03 {11:37:39 PM} 
1157
 
 #                                    version: 2.0
1158
 
 #  Author: Jonathan Guyer
1159
 
 #  E-mail: jguyer@his.com
1160
 
 #    mail: Alpha Cabal
1161
 
 #          POMODORO no seisan
1162
 
 #     www: http://www.his.com/jguyer/
1163
 
 #  
1164
 
 # ========================================================================
1165
 
 #               Copyright (c) 1999-2003 Jonathan Guyer
1166
 
 #                        All rights reserved
1167
 
 # ========================================================================
1168
 
 # Permission to use, copy, modify, and distribute this software and its
1169
 
 # documentation for any purpose and without fee is hereby granted,
1170
 
 # provided that the above copyright notice appear in all copies and that
1171
 
 # both that the copyright notice and warranty disclaimer appear in
1172
 
 # supporting documentation.
1173
 
 # 
1174
 
 # Jonathan Guyer disclaims all warranties with regard to this software,
1175
 
 # including all implied warranties of merchantability and fitness.  In
1176
 
 # no event shall Jonathan Guyer be liable for any special, indirect or
1177
 
 # consequential damages or any damages whatsoever resulting from loss of
1178
 
 # use, data or profits, whether in an action of contract, negligence or
1179
 
 # other tortuous action, arising out of or in connection with the use or
1180
 
 # performance of this software.
1181
 
 # ========================================================================
1182
 
 #  Description: 
1183
 
 # 
1184
 
 #  History
1185
 
 # 
1186
 
 #  modified   by  rev reason
1187
 
 #  ---------- --- --- -----------
1188
 
 #  1999-12-13 JEG 1.0 original
1189
 
 # ###################################################################
1190
 
 ##
1191
 
 
1192
 
# ◊◊◊◊ Initialization ◊◊◊◊ #
1193
 
 
1194
 
namespace eval tclAE::build {}
1195
 
 
1196
 
# ◊◊◊◊ Event handling ◊◊◊◊ #
1197
 
 
1198
 
## 
1199
 
 # -------------------------------------------------------------------------
1200
 
 # 
1201
 
 # "tclAE::build::throw" --
1202
 
 # 
1203
 
 #  Shorthand routine to check for AppleEvent errors
1204
 
 # -------------------------------------------------------------------------
1205
 
 ##
1206
 
proc tclAE::build::throw {args} {
1207
 
        # Event is only parsed for error checking, so purge
1208
 
        # when done (in the event of an error, it'll already
1209
 
        # be gone).
1210
 
        tclAE::disposeDesc [eval tclAE::build::event $args]
1211
 
}
1212
 
 
1213
 
## 
1214
 
 # -------------------------------------------------------------------------
1215
 
 # 
1216
 
 # "tclAE::build::event" --
1217
 
 # 
1218
 
 #  Encapsulation for new and old style event building.
1219
 
 # 
1220
 
 # Results:
1221
 
 #  The parsed result of the event.
1222
 
 # -------------------------------------------------------------------------
1223
 
 ##
1224
 
proc tclAE::build::event {args} {
1225
 
    set event [eval tclAE::send -r $args]
1226
 
    
1227
 
    # No error if these keywords are missing
1228
 
    if {[catch {tclAE::getKeyData $event "errn" "long"} errn]} {
1229
 
        set errn 0
1230
 
    }
1231
 
 
1232
 
    if {[catch {tclAE::getKeyData $event "errs" "TEXT"} errs]} {
1233
 
        set errs ""
1234
 
    }
1235
 
    
1236
 
    error::throwOSErr $errn $errs
1237
 
    
1238
 
    return $event
1239
 
}
1240
 
 
1241
 
## 
1242
 
 # -------------------------------------------------------------------------
1243
 
 # 
1244
 
 # "tclAE::build::resultDataAs" --
1245
 
 # 
1246
 
 #  Shorthand routine to get the direct object result of an AEBuild call
1247
 
 # -------------------------------------------------------------------------
1248
 
 ##
1249
 
proc tclAE::build::resultDataAs {type args} {
1250
 
    global errorMsg
1251
 
    
1252
 
    set result ""
1253
 
    
1254
 
    set event [eval tclAE::build::event $args]
1255
 
    
1256
 
    if {[catch {set result [tclAE::getKeyData $event ---- $type]} errorMsg]} {
1257
 
        if {![string match "Missing keyword '*' in record" $errorMsg]} {
1258
 
            # No direct object is OK
1259
 
            error::display
1260
 
        }               
1261
 
    } 
1262
 
    
1263
 
    tclAE::disposeDesc $event
1264
 
    
1265
 
    return $result
1266
 
}
1267
 
 
1268
 
## 
1269
 
 # -------------------------------------------------------------------------
1270
 
 # 
1271
 
 # "tclAE::build::resultData" --
1272
 
 # 
1273
 
 #  Shorthand routine to get the direct object result of an AEBuild call
1274
 
 # -------------------------------------------------------------------------
1275
 
 ##
1276
 
proc tclAE::build::resultData {args} {
1277
 
    return [eval tclAE::build::resultDataAs **** $args]
1278
 
}
1279
 
 
1280
 
## 
1281
 
 # -------------------------------------------------------------------------
1282
 
 # 
1283
 
 # "tclAE::build::resultDescAs" --
1284
 
 # 
1285
 
 #  Shorthand routine to get the direct object result of an AEBuild call,
1286
 
 #  coercing to $type
1287
 
 # -------------------------------------------------------------------------
1288
 
 ##
1289
 
proc tclAE::build::resultDescAs {type args} {
1290
 
    global errorMsg
1291
 
    
1292
 
    set result ""
1293
 
    
1294
 
    set event [eval tclAE::build::event $args]
1295
 
    
1296
 
    if {[catch {set result [tclAE::getKeyDesc $event ---- $type]} errorMsg]} {
1297
 
        if {![string match "Missing keyword '*' in record" $errorMsg]} {
1298
 
            # No direct object is OK
1299
 
            error::display
1300
 
        }               
1301
 
    } 
1302
 
    
1303
 
    tclAE::disposeDesc $event
1304
 
    
1305
 
    return $result
1306
 
}
1307
 
 
1308
 
## 
1309
 
 # -------------------------------------------------------------------------
1310
 
 # 
1311
 
 # "tclAE::build::resultDesc" --
1312
 
 # 
1313
 
 #  Shorthand routine to get the direct object result of an AEBuild call,
1314
 
 #  retaining the type code
1315
 
 # -------------------------------------------------------------------------
1316
 
 ##
1317
 
proc tclAE::build::resultDesc {args} {
1318
 
    return [eval tclAE::build::resultDescAs **** $args]
1319
 
}
1320
 
 
1321
 
## 
1322
 
 # -------------------------------------------------------------------------
1323
 
 # 
1324
 
 # "tclAE::build::protect" --
1325
 
 # 
1326
 
 #  Alpha seems pickier about ident lengths than AEGizmos says it should be. 
1327
 
 #  Protect any whitespace.
1328
 
 # 
1329
 
 # Results:
1330
 
 #  Returns $value, possible bracketed with ' quotes
1331
 
 # 
1332
 
 # Side effects:
1333
 
 #  None.
1334
 
 # -------------------------------------------------------------------------
1335
 
 ##
1336
 
proc tclAE::build::protect {value} {
1337
 
        set value [string trimright $value]
1338
 
        if {[regexp {[][ @‘'“”:,({})-]} $value blah]} {
1339
 
                set quote 1
1340
 
        } else {
1341
 
                set quote 0
1342
 
        }
1343
 
        
1344
 
        set value [format "%-4.4s" $value]
1345
 
        
1346
 
        if {$quote} {
1347
 
                set value "'${value}'"          
1348
 
        } 
1349
 
        
1350
 
        return $value
1351
 
}
1352
 
 
1353
 
proc tclAE::build::objectProperty {process property object} {
1354
 
        return [tclAE::build::resultData $process core getd ---- \
1355
 
                                [tclAE::build::propertyObject $property $object]]
1356
 
}
1357
 
 
1358
 
# ◊◊◊◊ Builders ◊◊◊◊ #
1359
 
 
1360
 
proc tclAE::build::coercion {fromValue toType} {
1361
 
        set toType [tclAE::build::protect $toType]
1362
 
 
1363
 
        switch -- [string index $fromValue 0] {
1364
 
                "\{" { # value is record
1365
 
                        return "${toType}${fromValue}"
1366
 
                }
1367
 
                "\[" { # value is list
1368
 
                        set msg "Cannot coerce a list"
1369
 
                        error $msg "" [list AEParse 16 $msg]
1370
 
                }
1371
 
                default {
1372
 
                        return "${toType}(${fromValue})"
1373
 
                }
1374
 
        }
1375
 
}
1376
 
 
1377
 
## 
1378
 
 # -------------------------------------------------------------------------
1379
 
 # 
1380
 
 # "tclAE::build::List" --
1381
 
 # 
1382
 
 #  Convert list 'l' to an AE list, i.e., "[l1, l2, l3, ...]".
1383
 
 #  "-as type" coerces elements to 'type' before joining.  
1384
 
 #  Set "-untyped" if the elements do not consist of AEDescriptors
1385
 
 # -------------------------------------------------------------------------
1386
 
 ##
1387
 
proc tclAE::build::List {l args} {
1388
 
        set opts(-as) ""
1389
 
        set opts(-untyped) 0
1390
 
        getOpts as
1391
 
        
1392
 
        if {[string length $opts(-as)] != 0} {
1393
 
                set out {}
1394
 
                foreach item $l {
1395
 
                        lappend out [tclAE::build::$opts(-as) $item]
1396
 
                }
1397
 
        } elseif {!$opts(-untyped)} {
1398
 
                set out {}
1399
 
                foreach item $l {
1400
 
                        lappend out $item
1401
 
                }               
1402
 
        } else {
1403
 
                set out $l
1404
 
        }
1405
 
        
1406
 
        set out [join $out ", "]
1407
 
        return "\[$out\]"
1408
 
}
1409
 
 
1410
 
## 
1411
 
 # -------------------------------------------------------------------------
1412
 
 # 
1413
 
 # "tclAE::build::hexd" --
1414
 
 # 
1415
 
 #  Convert 'value' to '«value»'.
1416
 
 #  value's spaces are stripped and it is left-padded with 0 to even digits.
1417
 
 # -------------------------------------------------------------------------
1418
 
 ##
1419
 
proc tclAE::build::hexd {value} {
1420
 
        set newval $value
1421
 
        if {[string length $newval] % 2} {
1422
 
                # left pad with zero to make even number of digits
1423
 
                set newval "0${newval}"
1424
 
        } 
1425
 
        if {![is::Hexadecimal $newval]} {
1426
 
            if {[is::Whitespace $newval]} {
1427
 
                return ""
1428
 
            } else {
1429
 
                set msg "Non-hex-digit in \u00ab${value}\u00bb" 
1430
 
                error $msg "" [list AECoerce 6 $msg]
1431
 
            }
1432
 
        } else {
1433
 
                return "\u00ab${newval}\u00bb"
1434
 
        }
1435
 
}
1436
 
 
1437
 
## 
1438
 
 # -------------------------------------------------------------------------
1439
 
 # 
1440
 
 # "tclAE::build::bool" --
1441
 
 # 
1442
 
 #  Convert 'val' to AE 'bool(«val»)'.
1443
 
 # -------------------------------------------------------------------------
1444
 
 ##
1445
 
proc tclAE::build::bool {val} {
1446
 
    if {$val} {
1447
 
        set val 1
1448
 
    } else {
1449
 
        set val 0
1450
 
    }
1451
 
    
1452
 
    return [tclAE::build::coercion [tclAE::build::hexd $val] bool]
1453
 
}
1454
 
 
1455
 
## 
1456
 
 # -------------------------------------------------------------------------
1457
 
 # 
1458
 
 # "tclAE::build::TEXT" --
1459
 
 #  
1460
 
 #  Convert $txt to “TEXT”.
1461
 
 #  If there are curly quotes in $txt, output in raw hex, coerced to TEXT
1462
 
 # -------------------------------------------------------------------------
1463
 
 ##
1464
 
proc tclAE::build::TEXT {txt} {
1465
 
   if {$txt == ""} {
1466
 
     return "[tclAE::build::coercion {} TEXT]"
1467
 
   }
1468
 
   if {[regexp {[\u0000-\u001f\u201c\u201d]} $txt]} {
1469
 
     binary scan $txt H* hexd
1470
 
     return "[tclAE::build::coercion [tclAE::build::hexd $hexd] TEXT]"
1471
 
   }
1472
 
   return "\u201c${txt}\u201d"
1473
 
}
1474
 
 
1475
 
## 
1476
 
 # -------------------------------------------------------------------------
1477
 
 # 
1478
 
 # "tclAE::build::alis" --
1479
 
 # 
1480
 
 #  Convert 'path' to an alis(«...»).
1481
 
 # -------------------------------------------------------------------------
1482
 
 ##
1483
 
proc tclAE::build::alis {path} {
1484
 
    return [tclAE::coerceData TEXT $path alis]
1485
 
}
1486
 
 
1487
 
## 
1488
 
 # -------------------------------------------------------------------------
1489
 
 # 
1490
 
 # "tclAE::build::fss" --
1491
 
 # 
1492
 
 #  Convert 'path' to an 'fss '(«...»).
1493
 
 # -------------------------------------------------------------------------
1494
 
 ##
1495
 
proc tclAE::build::fss {path} {
1496
 
    return [tclAE::coerceData TEXT $path fss]
1497
 
}
1498
 
 
1499
 
## 
1500
 
 # -------------------------------------------------------------------------
1501
 
 # 
1502
 
 # "tclAE::build::path" --
1503
 
 # 
1504
 
 #  Convert 'path' to an alis(«...») or a furl(“...”), depending on OS.
1505
 
 # -------------------------------------------------------------------------
1506
 
 ##
1507
 
proc tclAE::build::path {path} {
1508
 
    global tcl_platform
1509
 
    
1510
 
    # For some inexplicable reason, Apple decided that aliases
1511
 
    # cannot refer to non-existent files on Mac OS X, so 
1512
 
    # we create a CFURL instead
1513
 
    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
1514
 
        return "furl([tclAE::build::TEXT $path])"
1515
 
    } else {
1516
 
        return [tclAE::coerceData TEXT $path alis]
1517
 
    }
1518
 
}
1519
 
 
1520
 
## 
1521
 
 # -------------------------------------------------------------------------
1522
 
 # 
1523
 
 # "tclAE::build::ident" --
1524
 
 # 
1525
 
 #  Dummy proc for rebuilding AEGizmos strings from parsed lists
1526
 
 # -------------------------------------------------------------------------
1527
 
 ##
1528
 
proc tclAE::build::enum {enum} {
1529
 
    return [tclAE::build::protect $enum]
1530
 
}
1531
 
 
1532
 
 
1533
 
proc tclAE::build::name {name} {
1534
 
    return "form:'name', seld:[tclAE::build::TEXT $name]"
1535
 
}
1536
 
 
1537
 
proc tclAE::build::filename {name} {
1538
 
    global tcl_platform
1539
 
    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
1540
 
        set name [tclAE::getHFSPath $name]
1541
 
    } 
1542
 
    return "obj{want:type('file'), from:'null'(), [tclAE::build::name $name] } "
1543
 
}
1544
 
 
1545
 
proc tclAE::build::winByName {name} {
1546
 
    return "obj{want:type('cwin'), from:'null'(), [tclAE::build::name $name]}"
1547
 
}
1548
 
 
1549
 
proc tclAE::build::winByPos {absPos} {
1550
 
    return "obj{want:type('cwin'), from:'null'(), [tclAE::build::absPos $absPos]}"
1551
 
}
1552
 
 
1553
 
proc tclAE::build::lineRange {absPos1 absPos2} {
1554
 
    set lineObj1 "obj{want:type('clin'), from:'ccnt'(), [tclAE::build::absPos $absPos1]}"
1555
 
    set lineObj2 "obj{want:type('clin'), from:'ccnt'(), [tclAE::build::absPos $absPos2]}"
1556
 
    return "form:'rang', seld:rang{star:$lineObj1, stop:$lineObj2}"
1557
 
}
1558
 
 
1559
 
proc tclAE::build::charRange {absPos1 absPos2} {
1560
 
    set charObj1 "obj{want:type('cha '), from:'ccnt'(), [tclAE::build::absPos $absPos1]}"
1561
 
    set charObj2 "obj{want:type('cha '), from:'ccnt'(), [tclAE::build::absPos $absPos2]}"
1562
 
    return "form:'rang', seld:rang{star:$charObj1, stop:$charObj2}"
1563
 
}
1564
 
 
1565
 
proc tclAE::build::absPos {posName} {
1566
 
    #
1567
 
    # Use '1' or 'first' to specify first position
1568
 
    # and '-1' or 'last' to specify last position.
1569
 
    #
1570
 
    if {$posName == "first"} { 
1571
 
        set posName 1 
1572
 
    } elseif {$posName == "last"} { 
1573
 
        set posName -1 
1574
 
    }
1575
 
    if {[is::Integer $posName]} {
1576
 
        return "form:indx, seld:long($posName)"
1577
 
    } else {
1578
 
        error "tclAE::build::absPos: bad argument"
1579
 
    }
1580
 
}
1581
 
 
1582
 
proc tclAE::build::nullObject {} { 
1583
 
    return "'null'()" 
1584
 
}
1585
 
 
1586
 
proc tclAE::build::objectType {type} { 
1587
 
        return "type($type)" 
1588
 
}
1589
 
 
1590
 
proc tclAE::build::nameObject {type name {from ""}}     {
1591
 
    if {$from == ""} {
1592
 
        set from [tclAE::build::nullObject]
1593
 
    } 
1594
 
    return "obj \{ \
1595
 
      form:name, \
1596
 
      want:[tclAE::build::objectType $type], \
1597
 
      seld:$name, \
1598
 
      from:$from \
1599
 
    \}" 
1600
 
}
1601
 
 
1602
 
proc tclAE::build::indexObject {type ind {from ""}} {
1603
 
    if {$from == ""} {
1604
 
        set from [tclAE::build::nullObject]
1605
 
    } 
1606
 
    return "obj \{ \
1607
 
      form:indx, \
1608
 
      want:[tclAE::build::objectType $type], \
1609
 
      seld:$ind, \
1610
 
      from:$from \
1611
 
    \}" 
1612
 
}
1613
 
 
1614
 
proc tclAE::build::everyObject {type {from ""}} {
1615
 
    return [tclAE::build::indexObject $type "abso('all ')" $from]
1616
 
}
1617
 
 
1618
 
proc tclAE::build::rangeObject {type absPos1 absPos2 {from ""}} {
1619
 
    if {$from == ""} {
1620
 
        set from [tclAE::build::nullObject]
1621
 
    } 
1622
 
    set type [tclAE::build::objectType $type]
1623
 
    
1624
 
    set obj1 "obj{                      \
1625
 
        want:$type,                     \
1626
 
        from:'ccnt'(),                  \
1627
 
        [tclAE::build::absPos $absPos1] \
1628
 
    }"
1629
 
    set obj2 "obj{                      \
1630
 
        want:$type,                     \
1631
 
        from:'ccnt'(),                  \
1632
 
        [tclAE::build::absPos $absPos2] \
1633
 
    }"
1634
 
    return "obj {     \
1635
 
      form:rang,      \
1636
 
      want:$type,     \
1637
 
      seld:rang{      \
1638
 
        star:$obj1,   \
1639
 
        stop:$obj2    \
1640
 
      },              \
1641
 
      from:$from      \
1642
 
    }" 
1643
 
}
1644
 
 
1645
 
proc tclAE::build::propertyObject {prop {object ""}} { 
1646
 
    if {[string length $object] == 0} {
1647
 
        set object [tclAE::build::nullObject]
1648
 
    } 
1649
 
    
1650
 
    return "obj \{\
1651
 
      form:prop, \
1652
 
      want:[tclAE::build::objectType prop], \
1653
 
      seld:[tclAE::build::objectType $prop], \
1654
 
      from:$object \
1655
 
    \}" 
1656
 
}
1657
 
 
1658
 
proc tclAE::build::propertyListObject {props {object ""}} { 
1659
 
    if {[string length $object] == 0} {
1660
 
        set object [tclAE::build::nullObject]
1661
 
    } 
1662
 
    
1663
 
    return "obj \{\
1664
 
      form:prop, \
1665
 
      want:[tclAE::build::objectType prop], \
1666
 
      seld:[tclAE::build::List $props -as objectType], \
1667
 
      from:$object \
1668
 
    \}" 
1669
 
}
1670
 
 
1671
 
# ◊◊◊◊ Utilities ◊◊◊◊ #
1672
 
 
1673
 
## 
1674
 
 # -------------------------------------------------------------------------
1675
 
 # 
1676
 
 # "tclAE::build::startupDisk" --
1677
 
 # 
1678
 
 #  The name of the Startup Disk (as sometimes returned by the Finder)
1679
 
 # -------------------------------------------------------------------------
1680
 
 ##
1681
 
proc tclAE::build::startupDisk {} {
1682
 
    return [tclAE::build::objectProperty 'MACS' pnam \
1683
 
      "obj \{want:type(prop), from:'null'(), \
1684
 
      form:prop, seld:type(sdsk)\}" \
1685
 
    ]   
1686
 
}
1687
 
 
1688
 
## 
1689
 
 # -------------------------------------------------------------------------
1690
 
 # 
1691
 
 # "tclAE::build::userName" --
1692
 
 # 
1693
 
 #  Return the default user name. The Mac's owner name,
1694
 
 #  which is in String Resource ID -16096, is inaccesible to Tcl 
1695
 
 #  (at least until Tcl 8 is implemented).
1696
 
 #  
1697
 
 #  Try different mechanisms for determining the user name.
1698
 
 #  
1699
 
 # -------------------------------------------------------------------------
1700
 
 ##
1701
 
if {([info exists alpha::platform] && ${alpha::platform} != "alpha") || 
1702
 
        ($tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin")} {
1703
 
    ;proc tclAE::build::userName {} {
1704
 
        global env
1705
 
        
1706
 
        # better to use tcl_platform(user)?
1707
 
        return $env(USER)
1708
 
    }
1709
 
} else {
1710
 
    ;proc tclAE::build::userName {} {
1711
 
        return [text::fromPstring [resource read "STR " -16096]]
1712
 
    }
1713
 
}    
1714
 
 
1715
 
# Build a Folder object from its name
1716
 
proc tclAE::build::foldername {name} {
1717
 
    global tcl_platform
1718
 
    if {$tcl_platform(platform) == "unix" && $tcl_platform(os) == "Darwin"} {
1719
 
        set name [tclAE::getHFSPath $name]
1720
 
    } 
1721
 
    return "obj{want:type('cfol'), from:'null'(), [tclAE::build::name $name] } "
1722
 
}