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}