Script Library: native-requestors.r

Script Library: 1247 scripts
native-requestors.r

REBOL [
    Author: "Ashley G Truter"
    File:   %native-requestors.r
    Date:   15-Jul-2009
    Title:  "Native requestors"
    Purpose: {
        Replaces a number of REBOL requestors with native equivalents.
        Windows requires COMLib.r from http://anton.wildit.net.au/rebol/os/windows/COMLib/

        REQUESTOR           Mac Win
        alert               Y   Y
        confirm             Y   Y
        request             Y   Y
        request-color       Y   N
        request-date        N   N
        request-dir         Y   Y
        request-download    N   N
        request-file        N   N
        request-list        Y   N
        request-pass        Y   N
        request-text        Y   Y
        say (new)           Y   Y
        
        Added following requestors/funcs:
            open-file
            save-file
            send-keys (Windows uses tmp.vbs)
    }
    Notes: {
        Windows can probably use COMDLG32.DLL (http://support.microsoft.com/kb/153929) for request-color
        and the Win32 API for many of these funcs.

        The send-keys use of VBS is an ugly hack. Much better to use COMLib or Win32 API ... but I havn't
        figured out how yet.
    }
    library: [
        level: 'intermediate
        platform: [windows mac]
        type: [tool function]
        domain: [dialogs]
        tested-under: [view 2.7.6 [WinXP MacOSX]]
        support: none
        license: 'public-domain
        see-also: none
    ]   
]

make object! [

    OS: either 3 = fourth system/version [
        ;
        ;   Windows
        ;
        COMLib: do %COMLib.r
        COMLib/initialize
        do bind [
            sapi5: make function! [
                "Use SAPI 5 for text to speech."
                text [string!]
                /local tts
            ][
                tts: CreateObject "Sapi.SpVoice"
                CallMethod [tts ".Speak(%s)" text]
                release tts
            ]

            vbscript: make function! [
                cmd [string!]
                /string
                /local MS_script result
            ][
                MS_script: CreateObject "MSScriptControl.ScriptControl"
                PutValue [MS_script ".Language = %s" "VBScript"]
                PutValue [MS_script ".AllowUI = %s" "TRUE"]
                PutValue [MS_script ".UseSafeSubset = %s" "0"]
                result: either string [
                    GetString [MS_script ".Eval(%s)" cmd]
                ][
                    GetInteger [MS_script ".Eval(%s)" cmd]
                ]
                release MS_script
                result
            ]

            BrowseForFolder: make function! [
                prompt [string!] "Prompt text"
                dir [string!] "Starting directory"
                /local MS_shell obj result
            ][
                MS_shell: CreateObject "Shell.Application"
                obj: GetObject reduce [MS_Shell {.BrowseForFolder(%d,%s,%d,%s)} 0 prompt 8 dir]
                result: either zero? obj [none] [
                    obj: GetObject [obj {.Self}]
                    dirize to-rebol-file GetString [obj {.Path}]
                ]
                obj: none
                release MS_shell
                result
            ]
        ] COMLib/api

        'Win
    ][
        ;
        ;   Mac OSX
        ;
        osascript: make function! [
            cmd [string!]
            /local v
        ][
            call/output/error rejoin [
                {osascript -e 'tell app "System Events"' -e 'activate' -e '}
                cmd
                {' -e 'end'}
            ] v: copy "" copy ""
            trim/lines v
        ]
        
        set 'request-color make function! [
            "Requests a color."
            /title text [string!] "Title text"      ; not supported
            /color clr [tuple!] "Default color"
            /local v
        ][
            v: copy "choose color"
            all [
                color
                insert tail v reform [
                    " default color"
                    *list reduce [256 * first clr 256 * second clr 256 * third clr]
                ]
            ]
            either empty? v: parse osascript v "," [none] [
                to tuple! reduce [
                    to integer! (to integer! first v) / 256
                    to integer! (to integer! second v) / 256
                    to integer! (to integer! third v) / 256
                ]
            ]
        ]

        set 'request-list make function! [
            "Requests a selection from a list."
            prompt [string!]
            items [block!]
            /title text [string!]
            /default val [any-type!]
            /local v
        ][
            v: reform [
                "choose from list " *list/force items
                "with title" mold any [text ""]
                "with prompt" mold any [prompt "Please make your selection:"]
            ]
            all [default insert tail v join " default items " *list/force to block! val]
            either "false" = v: osascript v [none] [v]
        ]

        set 'request-pass make function! [
            "Requests a password."
            /title text [string!]
            /local v
        ][
            either empty? v: osascript join {display dialog "Password:" hidden answer true default answer "" with title} mold any [text "Password"] [none] [v: copy skip v 14 copy/part v -1 + index? find/last v ","]
        ]
        
        'Mac
    ]

    ;
    ;   Helper func
    ;
    
    delims: either OS = 'Win [copy "()"] [copy "{}"]

    *list: make function! [block [block!] /force /local v] [
        v: copy delims
        foreach item block [
            insert back tail v join either any [force string? item] [mold form item] [form item] ","
        ]
        head remove back back tail v
    ]

    ;
    ;   Native requestors
    ;

    set 'request-dir make function! [
        "Requests a directory."
        /title text [string!] "Title text"
        /dir path [file!] "Set starting directory"
        /local v
    ][
        either OS = 'Win [
            BrowseForFolder any [text "Select a directory:"] either dir [to-local-file path] ["C:"]
        ][
            v: join "choose folder with prompt " mold any [text ""]
            all [dir insert tail v join " default location alias " mold join "Macintosh HD" replace/all to-local-file path "/" ":"]
            either empty? v: osascript v [none] [dirize to-rebol-file replace/all find next v ":" ":" "/"]
        ]
    ]

    set 'request-text make function! [
        "Requests a value."
        /title text [string!] "Title text"
        /prompt string [string!] "Prompt string"
        /default value [any-type!] "Default value"
        /local v
    ][
        text:   any [text "Dialog"]
        string: any [string "Enter text below:"]
        value:  form any [value ""]
        either OS = 'Win [
            vbscript/string rejoin ["InputBox" *list reduce [string text value]]
        ][
            either empty? v: osascript reform ["display dialog" mold string "default answer" mold value "with title" mold text] [
                none
            ][
                v: copy skip v 14
                copy/part v -1 + index? find/last v ","
            ]
        ]
    ]

    set 'request make function! [
        "Requests an answer to a simple question."
        prompt [string!]
        /title text [string!]
        /ok
        /confirm
        /type icon [word!] "Valid values are: alert, help, info, stop"
        /local v opt
    ][
        either OS = 'Win [
            opt: 4096 + case [OK [0] Confirm [4] true [3]]
            all [type opt: opt + select [alert 48 help 32 info 64 stop 16] icon]
            v: vbscript join "MsgBox" *list reduce [prompt opt any [text "Dialog"]]
        ][
            v: reform ["display dialog" mold prompt "with title" mold any [text ""]]
            insert tail v join " buttons " case [
                ok      [*list ["OK"]]
                confirm [*list ["Yes" "No"]]
                true    [*list ["Yes" "No" "Cancel"]]
            ]
            insert tail v join " default button " mold either ok ["OK"] ["Yes"]
            all [type insert tail v join " with icon " select [alert "caution" help "note" info "note" stop "stop"] icon]
;           all [type insert tail v join " with icon alias " mold "Macintosh HD:Users:Ash:REBOL:Projects:BAS-Buster:Icons:alert.icns"]
            v: copy skip osascript v 16
        ]
        select reduce ["Yes" true "No" false "Cancel" none "" none 1 true 2 none 6 true 7 false] v
    ]
    
    set 'alert make function! [
        "Flashes an alert message to the user. Waits for a user response."
        value [any-type!]
        /title text [string!]
    ][
        request/ok/type/title form value 'alert any [text "Alert"]
    ]
    
    set 'confirm make function! [
        "Confirms a user choice."
        question [any-type!] "Prompt to user"
        /title text [string!]
    ][
        request/confirm/type/title form question 'help any [text "Confirm"]
    ]

    set 'open-file make function! [
        /dir path [file!] "Default file name"
    ][
        all [ 
            local-request-file path: reduce ["Open" "" clean-path %. either dir [compose [(path)]] [copy []][][] false false]
            join third path first fourth path
        ]
    ]

    set 'save-file make function! [
        /dir path [file!] "Default file name"
    ][
        all [ 
            local-request-file path: reduce ["Save" "" clean-path %. either dir [compose [(path)]] [copy []][][] false true]
            join third path first fourth path
        ]
    ]

    set 'send-keys make function! [
        url [url!]
        keystrokes [block!]
        /local cmd
    ][
        browse url
        wait 3
        either OS = 'Win [
            cmd: copy "^"+{TAB}{TAB}^""
            foreach token keystrokes [
                insert back tail cmd switch/default token [
                    #"^-" ["{TAB}"]
                    #"^/" ["{ENTER}"]
                ] [token]
            ]
            write %tmp.vbs join {set s=WScript.CreateObject("WScript.Shell")^/s.AppActivate "Windows Internet Explorer"^/s.SendKeys } cmd
            call/wait %tmp.vbs
            delete %tmp.vbs
        ][
            cmd: copy {'}
            foreach token keystrokes [
                insert back tail cmd join " & " switch/default token [
                    #"^-" ["tab"]
                    #"^/" ["return"]
                ] [mold token]
            ]
            call join {osascript -e 'tell app "Safari" to activate' -e 'tell app "System Events" to keystroke } skip cmd 3
        ]
    ]

    set 'say: make function! [
        "Speaks text."
        text [string!]
        /using voice [string!]  ; Mac only
    ][
        either OS = 'Win [
            sapi5 text
        ][
            call rejoin [
                {osascript -e 'say }
                mold text
                either using [rejoin [{ using } mold voice {'}]] [{'}]
            ]
        ]
        true
    ]
]

do [
    alert "This is an alert."
    confirm "This is the confirm requestor."
    request "This is the base request function."
    request-color
    ;request-date
    request-dir
    ;request-download
    ;request-file
    request-list "This is the request-list requestor." ["List" "of" "items"]
    request-pass
    request-text
    say "This is the new say function."
    open-file
    save-file
    send-keys http://www.rebol.com reduce [tab "R3" newline]
    all [3 = fourth system/version COMLib/cleanup]
]