aebuild.tcl

It s a tool designed to extract as much information as possible from Bluetooth devices without the r

## -*-Tcl-*-
 # ###################################################################
 #  TclAE - Functions for building AppleEvents 
 #  			(modernization of appleEvents.tcl)
 # 
 #  FILE: "aebuild.tcl"
 #                                    created: 12/13/99 {12:55:28 PM} 
 #                                last update: 4/7/03 {11:37:39 PM} 
 #                                    version: 2.0
 #  Author: Jonathan Guyer
 #  E-mail: [e-mail]
 #    mail: Alpha Cabal
 #          POMODORO no seisan
 #     www: http://www.his.com/jguyer/
 #  
 # ========================================================================
 #               Copyright (c) 1999-2003 Jonathan Guyer
 #                        All rights reserved
 # ========================================================================
 # Permission to use, copy, modify, and distribute this software and its
 # documentation for any purpose and without fee is hereby granted,
 # provided that the above copyright notice appear in all copies and that
 # both that the copyright notice and warranty disclaimer appear in
 # supporting documentation.
 # 
 # Jonathan Guyer disclaims all warranties with regard to this software,
 # including all implied warranties of merchantability and fitness.  In
 # no event shall Jonathan Guyer be liable for any special, indirect or
 # consequential damages or any damages whatsoever resulting from loss of
 # use, data or profits, whether in an action of contract, negligence or
 # other tortuous action, arising out of or in connection with the use or
 # performance of this software.
 # ========================================================================
 #  Description: 
 # 
 #  History
 # 
 #  modified   by  rev reason
 #  ---------- --- --- -----------
 #  1999-12-13 JEG 1.0 original
 # ###################################################################
 ##

# ◊◊◊◊ Initialization ◊◊◊◊ #

namespace eval tclAE::build {}

# ◊◊◊◊ Event handling ◊◊◊◊ #

## 
 # -------------------------------------------------------------------------
 # 
 # "tclAE::build::throw" --
 # 
 #  Shorthand routine to check for AppleEvent errors
 # -------------------------------------------------------------------------
 ##
proc tclAE::build::throw {args} {
	# Event is only parsed for error checking, so purge
	# when done (in the event of an error, it'll already
	# be gone).
	tclAE::disposeDesc [eval tclAE::build::event $args]
}

## 
 # -------------------------------------------------------------------------
 # 
 # "tclAE::build::event" --
 # 
 #  Encapsulation for new and old style event building.
 # 
 # Results:
 #  The parsed result of the event.
 # -------------------------------------------------------------------------
 ##
proc tclAE::build::event {args} {
    set event [eval tclAE::send -r $args]
    
    # No error if these keywords are missing
    if {[catch {tclAE::getKeyData $event "errn" "long"} errn]} {
	set errn 0
    }

    if {[catch {tclAE::getKeyData $event "errs" "TEXT"} errs]} {
	set errs ""
    }
    
    error::throwOSErr $errn $errs
    
    return $event
}

## 
 # -------------------------------------------------------------------------
 # 
 # "tclAE::build::resultDataAs" --
 # 
 #  Shorthand routine to get the direct object result of an AEBuild call
 # -------------------------------------------------------------------------
 ##
proc tclAE::build::resultDataAs {type args} {
    global errorMsg
    
    set result ""
    
    set event [eval tclAE::build::event $args]
    
    if {[catch {set result [tclAE::getKeyData $event ---- $type]} errorMsg]} {
	if {![string match "Missing keyword '*' in record" $errorMsg]} {
	    # No direct object is OK
	    error::display
	}		
    } 
    
    tclAE::disposeDesc $event
    
    return $result
}

## 
 # -------------------------------------------------------------------------
 # 
 # "tclAE::build::resultData" --
 # 
 #  Shorthand routine to get the direct object result of an AEBuild call
 # -------------------------------------------------------------------------
 ##
proc tclAE::build::resultData {args} {
    return [eval tclAE::build::resultDataAs **** $args]
}

## 
 # -------------------------------------------------------------------------
 # 
 # "tclAE::build::resultDescAs" --
 # 
 #  Shorthand routine to get the direct object result of an AEBuild call,
 #  coercing to $type
 # -------------------------------------------------------------------------
 ##
proc tclAE::build::resultDescAs {type args} {
    global errorMsg
    
    set result ""
    
    set event [eval tclAE::build::event $args]
    
    if {[catch {set result [tclAE::getKeyDesc $event ---- $type]} errorMsg]} {
	if {![string match "Missing keyword '*' in record" $errorMsg]} {
	    # No direct object is OK
	    error::display
	}		
    } 
    
    tclAE::disposeDesc $event
    
    return $result
}

## 
 # -------------------------------------------------------------------------
 # 
 # "tclAE::build::resultDesc" --
 # 
 #  Shorthand routine to get the direct object result of an AEBuild call,
 #  retaining the type code
 # -------------------------------------------------------------------------
 ##
proc tclAE::build::resultDesc {args} {
    return [eval tclAE::build::resultDescAs **** $args]
}

## 
 # -------------------------------------------------------------------------
 # 
 # "tclAE::build::protect" --
 # 
 #  Alpha seems pickier about ident lengths than AEGizmos says it should be. 
 #  Protect any whitespace.
 # 
 # Results:
 #  Returns $value, possible bracketed with ' quotes
 # 
 # Side effects:
 #  None.
 # -------------------------------------------------------------------------
 ##
proc tclAE::build::protect {value} {
	set value [string trimright $value]
	if {[regexp {[][ @‘'“”:,({})-]} $value blah]} {
		set quote 1
	} else {
		set quote 0
	}
	
	set value [format "%-4.4s" $value]
	
	if {$quote} {
		set value "'${value}'"		
	} 
	
	return $value
}

proc tclAE::build::objectProperty {process property object} {
	return [tclAE::build::resultData $process core getd ---- \
				[tclAE::build::propertyObject $property $object]]
}

# ◊◊◊◊ Builders ◊◊◊◊ #

proc tclAE::build::coercion {fromValue toType} {
	set toType [tclAE::build::protect $toType]

	switch -- [string index $fromValue 0] {
		"\{" { # value is record
			return "${toType}${fromValue}"
		}
		"\[" { # value is list
			set msg "Cannot coerce a list"
			error $msg "" [list AEParse 16 $msg]
		}
		default {
			return "${toType}(${fromValue})"
		}
	}
}

## 
 # -------------------------------------------------------------------------
 # 
 # "tclAE::build::List" --
 # 
 #  Convert list 'l' to an AE list, i.e., "[l1, l2, l3, ...]".
 #  "-as type" coerces elements to 'type' before joining.  
 #  Set "-untyped" if the elements do not consist of AEDescriptors
 # -------------------------------------------------------------------------
 ##
proc tclAE::build::List {l args} {
	set opts(-as) ""
	set opts(-untyped) 0
	getOpts as
	
	if {[string length $opts(-as)] != 0} {
		set out {}
		foreach item $l {
			lappend out [tclAE::build::$opts(-as) $item]
		}
	} elseif {!$opts(-untyped)} {
		set out {}
		foreach item $l {
			lappend out $item
		}		
	} else {
		set out $l
	}
	
	set out [join $out ", "]
	return "\[$out\]"
}

## 
 # -------------------------------------------------------------------------
 # 
 # "tclAE::build::hexd" --
 # 
 #  Convert 'value' to '«value»'.
 #  value's spaces are stripped and it is left-padded with 0 to even digits.
 # -------------------------------------------------------------------------
 ##
proc tclAE::build::hexd {value} {
	set newval $value
	if {[string length $newval] % 2} {
		# left pad with zero to make even number of digits
		set newval "0${newval}"
	} 
	if {![is::Hexadecimal $newval]} {
	    if {[is::Whitespace $newval]} {
		return ""
	    } else {
		set msg "Non-hex-digit in \u00ab${value}\u00bb" 
		error $msg "" [list AECoerce 6 $msg]
	    }
	} else {
		return "\u00ab${newval}\u00bb"
	}
}