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 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 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 ## 76proc 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 ## 101proc 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 ## 128proc 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 ## 141proc 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 ## 169proc 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 ## 188proc 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 205proc 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 212proc 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 ## 239proc 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 ## 271proc 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 ## 297proc 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 ## 316proc 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 ## 335proc 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 ## 347proc 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 ## 359proc 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 ## 380proc tclAE::build::enum {enum} { 381 return [tclAE::build::protect $enum] 382} 383 384 385proc tclAE::build::name {name} { 386 return "form:'name', seld:[tclAE::build::TEXT $name]" 387} 388 389proc 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 397proc tclAE::build::winByName {name} { 398 return "obj{want:type('cwin'), from:'null'(), [tclAE::build::name $name]}" 399} 400 401proc tclAE::build::winByPos {absPos} { 402 return "obj{want:type('cwin'), from:'null'(), [tclAE::build::absPos $absPos]}" 403} 404 405proc 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 411proc 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 417proc 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 434proc tclAE::build::nullObject {} { 435 return "'null'()" 436} 437 438proc tclAE::build::objectType {type} { 439 return "type($type)" 440} 441 442proc 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 454proc 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 466proc tclAE::build::everyObject {type {from ""}} { 467 return [tclAE::build::indexObject $type "abso('all ')" $from] 468} 469 470proc 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 497proc 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 510proc 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 ## 533proc 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 ## 553if {([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 568proc 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