MacWorld 1998 March/Macworld (1998-03) (Disk 1).dmg/Shareware World/Utilities/Text Processing/Alpha/Tcl/SystemCode/appleEvents.tcl

Text File | 1997-12-10 | 9.5 KB | 322 lines | [TEXT/ALFA]

# make alias list to pass to AEBuild
proc makeAlis {name} {
    return "\[alis(«[coerce TEXT $name -x alis]»)\]"
}

proc makeFile {name} {
    return "alis(«[coerce TEXT $name -x alis]»)"
}

##
 # -------------------------------------------------------------------------
 #
 # "makeAlises" --
 #
 #  This proc has changed so it takes a list of items rather than an
 #  unknown number of args 'args'.  If 'l' is a list you must call
 #  this proc with 'makeAlises $l' rather than 'eval makeAlises $l'
 #  as was previously required.
 # -------------------------------------------------------------------------
 ##
proc makeAlises {names} {
    set str "\["
    set sep ""
    foreach name $names {
        append str "${sep}alis(«[coerce TEXT $name -x alis]»)"
        set sep ","
    }
    append str "\]"
    return $str
}


##
 # -------------------------------------------------------------------------
 #
 # "handleReply" --
 #
 #  Queued replies are passed through AEPrint and then to this routine.
 #
 #  If you write your own handleReply procedure, register it to this
 #  proc with:
 #
 #    currentReplyHandler 'my-proc-name'
 #
 #  Do this each time you send an event which may receive a reply.
 #  There is no need to register your proc at startup or any such
 #  'pre-registering'.  Just call the above proc _each_ time.
 #
 #  You proc should take one parameter (the reply), and should
 #  return '1' if it handled the reply, otherwise it can do/return
 #  anything else (although hopefully not much if it didn't handle
 #  anything).
 #
 #  If your replies often time-out or have other problems such
 #  that you don't handle them correctly, you may wish to register
 #  your reply-handler with 'currentReplyHandler 'my-proc' 1' which
 #  says 'only register if it's not already registered'.  Or you
 #  may wish to remove duplicates from the list of handlers
 #  directly.
 #
 # Results:
 #  depends on what is registered
 #
 # Side effects:
 #  calls other procs.  Removes handler from queue if it handled
 #  the reply.
 #
 # --Version--Author------------------Changes-------------------------------
 #    1.0     <[e-mail]> first one with hook handling
 #    2.0     <[e-mail]> different mechanism to give priority
 # -------------------------------------------------------------------------
 ##
proc handleReply {rep} {
    global lastReply replyHandlers
    set lastReply $rep
    set i 0
    foreach h $replyHandlers {
        if {$h != ""} {
            catch [list $h $rep] res
            if {$res == 1} {
                set replyHandlers [lreplace $replyHandlers $i $i]
                return
            }
        }
        incr i
    }
    message "Reply '$rep' not handled"
}

ensureset replyHandlers ""

##
 # -------------------------------------------------------------------------
 #
 # "currentReplyHandler" --
 #
 #  Add item to end of queue to receive replies, even if it is already
 #  in the queue, unless we set 'nodups'
 # -------------------------------------------------------------------------
 ##
proc currentReplyHandler {proc {nodups 0}} {
    global replyHandlers
    if {!$nodups || (![lcontains replyHandlers $proc])} {
        lappend replyHandlers $proc
    }
}

# Return an object record specifying the desired think project file.
proc fileObject {name} {
    join [concat {obj\{want:type('SFIL'), from:'null'(), form:'name', seld:“} [file tail $name] {”\}}] ""
}

proc sendOpenEvent {filler appname fname} {
    if {$filler == "noReply"} {
        AEBuild $appname aevt odoc "----" [makeAlis $fname]
    } else {
        AEBuild -r $appname aevt odoc "----" [makeAlis $fname]
    }
}


# Send open folder event to Finder. Name must end in colon.
proc openFolder {name} {
    if {![regexp ":$" $name]} {
        append name ":"
    }
    sendOpenEvent -r Finder $name
}

proc launchDoc {name} {
    set app [app::launchFore [getFileSig $name]]
    sendOpenEvent -r [file tail $app] $name
}

# Send multiple open events
proc sendOpenEvents {appname args} {
    AEBuild -r $appname aevt odoc "----" [makeAlises $args]
}

proc openAndSendFile {sig} {
    set fname [win::Current]
    if {[winDirty]} {
        if [dialog::yesno "Save '$fname'?"] {
            save
        }
    }

    set name [file tail [app::launchFore $sig]]
    sendOpenEvent noReply $name $fname
}

#================================================================================
# General Apple Event handling routines
#
# (written by Tom Pollard for use in the MacPerl package)
#================================================================================

# Quit an application.
proc sendQuitEvent {appname} {
    AEBuild $appname "aevt" "quit"
}

# Close one of an application's windows, designated by number.
proc sendCloseWinNum {appname num} {
    AEBuild $appname "core" "clos" "----" [AEWinByPos $num]
}

# Close one of an application's windows, designated by name.
proc sendCloseWinName {appname name} {
    AEBuild $appname "core" "clos" "----" [AEWinByName $name]
}

# Obtain the number of lines in one of an application's
# windows, designated by name.
proc sendCountLines {appname name} {
    set winObj [AEWinByName $name]
    set res [AEBuild -r $appname "core" "cnte" "----" $winObj kocl type('clin')]
    if {[regexp {:(.*)\}} $res allofit nlines]} {
        return $nlines
    } else {
        return 0
    }
}

# Get a selected range of lines from one of an application's
# windows, designated by name.  If $last is missing, then a single
# line is returned; if both $first and $last are missing, then
# the complete window contents are returned.
proc sendGetText {appname name {first {missing}} {last {missing}}} {
    global ALPHA
    set winObj [AEWinByName $name]
    if {$first != "missing"} {
        if {$last != "missing"} {
            set rangDesc [AELineRange $first $last]
        } else {
            set rangDesc [AEAbsPos $first]
        }
        set objDesc "obj{want:type('clin'), from:$winObj, $rangDesc }"
    } else {
        set objDesc "obj{want:type('ctxt'), from:$winObj, form:'indx', seld:abso('all') }"
    }
    set res [AEBuild -r $appname "core" "getd" "----" $objDesc]
    if {![regexp {“.*”} $res text]} { set text {} }
    return [string trim $text {“”}]
}

# Set a selected range of lines in one of an application's
# windows, designated by name.  If $last is missing, then a single
# line is changed; if both $first and $last are missing, then
# the complete window contents are replaced by the new text.
proc sendSetText {appname name text {first {missing}} {last {missing}}} {
    set winObj [AEWinByName $name]
    if {$first != "missing"} {
        if {$last != "missing"} {
            set rangDesc [AELineRange $first $last]
        } else {
            set rangDesc [AEAbsPos $first]
        }
        set objDesc "obj{want:type('clin'), from:$winObj, $rangDesc }"
    } else {
        set objDesc "obj{want:type('ctxt'), from:$winObj, form:'indx', seld:abso('all') }"
    }
    set res [AEBuild -r $appname "core" "setd" "----" $objDesc "data" [curlyq $text]]
    if {![regexp {“.*”} $res text]} { set text {} }
    return [string trim $text {“”}]
}

################################################################################
# Utility functions for constructing AppleEvent descriptors for AEBuild
################################################################################

proc AEFilename {name} {
    return "obj{want:type('file'), from:'null'(), [AEName $name] } "
}

proc AEWinByName {name} {
    return "obj{want:type('cwin'), from:'null'(), [AEName $name] } "
}

proc AEWinByPos {absPos} {
    return "obj{want:type('cwin'), from:'null'(), [AEAbsPos $absPos] } "
}

proc AELineRange {absPos1 absPos2} {
    set lineObj1 "obj{ want:type('clin'), from:'ccnt'(), [AEAbsPos $absPos1] }"
    set lineObj2 "obj{ want:type('clin'), from:'ccnt'(), [AEAbsPos $absPos2] }"
    return "form:'rang', seld:rang{star:$lineObj1, stop:$lineObj2 } "
}

proc AEAbsPos {posName} {
#
# Use '1' or 'first' to specify first position
# and '-1' or 'last' to specify last position.
#
    if {$posName == "first"} {
        set posName 1
    } elseif {$posName == "last"} {
        set posName -1
    }
    if {$posName >= -1} {
        return "form:indx, seld:long($posName)"
    } else {
        error "AEAbsPos: bad argument"
    }
}

proc AEName {name} {
    return "form:'name', seld:[curlyq $name]"
}

proc curlyq {str} {
    regsub -all {([“”])} $str {"} newstr
    return "\“$newstr\”"
}

################################################################################
proc nullObject {}                     { return "'null'()" }
proc objectType {type}                 { return "type($type)" }
proc nameObject {type name from}     { return "obj \{form:name, want:[objectType $type], seld:$name, from:$from\}" }
proc indexObject {type ind from}     { return "obj \{form:indx, want:[objectType $type], seld:$ind, from:$from\}" }
proc propertyObject { prop object } { return "obj \{form:prop, want:[objectType prop], seld:[objectType $prop], from:$object\}" }

# 'process' must have single quotes
proc buildMsgReply { process suite event args } { return [eval [list AEBuild -r $process $suite $event ] $args] }

proc countObjects { process fromObject class } {
    set res [AEBuild -r $process core cnte ---- $fromObject kocl [objectType $class]]
    if {[regexp {:([0-9]+)} $res dummy mtch]} {
        return $mtch
    } else {
        error "Bad count proc"
    }
}

proc createThingAtEnd {process container class} {
    set res [AEBuild -r $process core crel insh "insl \{kobj:$container\}" kocl "type($class)"]
}


proc getObjectData { process class name from } {
    set res [AEBuild -r $process core getd ---- [nameObject $class "“$name”" $from] {rtyp{type:TEXT}}]
    if {[regexp {“(.*)”} $res dummy mtch]} {
        return $mtch
    } else {
        error "Bad count proc"
    }
}


proc objectProperty { process property object } {
    AEBuild -r $process core getd ---- [propertyObject $property $object]
}

# Extract and return a path from a result.
proc extractPath {res} {
    if {[regexp {«(.*)»} $res dummy fss]} {
        return [specToPathName $fss]
    }
    error "bad path $name"
}