home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / gprocs / window.icn < prev    next >
Text File  |  2000-07-29  |  12KB  |  381 lines
  1. ############################################################################
  2. #
  3. #    File:     window.icn
  4. #
  5. #    Subject:  Procedure for opening window
  6. #
  7. #    Author:   Gregg M. Townsend
  8. #
  9. #    Date:     October 10, 1997
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #  Window() opens a window with provisions for option processing and
  18. #  error handling.  The returned window is assigned to &window if
  19. #  &window is null.  If the window cannot be opened, the program is
  20. #  aborted.
  21. #
  22. #  The characteristics of the window are set from several sources:
  23. #  Window's arguments, optionally including the program argument list;
  24. #  user defaults; and built-in defaults.  These built-in defaults are
  25. #  the same as for optwindow(): bg=pale gray, fg=black, size=500,300.
  26. #
  27. ############################################################################
  28. #
  29. #  With one exception, arguments to Window() are attribute specifications
  30. #  such as those used with open() and WAttrib().  Order is significant,
  31. #  with later attributes overriding earlier ones.
  32. #
  33. #  Additionally, the program argument list -- the single argument passed
  34. #  to the main procedure -- can be passed as an argument to Window().
  35. #  Options specified with a capital letter are removed from the list and
  36. #  interpreted as attribute specifications, again in a manner consistent
  37. #  with optwindow().
  38. #
  39. #  Because the Window() arguments are processed in order, attributes that
  40. #  appear before the program arglist can be overridden by command-line
  41. #  options when the program is executed.  If attributes appear after the
  42. #  program arglist, they cannot be overridden.  For example, with
  43. #
  44. #    procedure main(args)
  45. #    Window("size=600,400", "fg=yellow", args, "bg=black")
  46. #
  47. #  the program user can change the size and foreground color
  48. #  but not the background color.
  49. #
  50. #  User defaults are applied at the point where the program arglist appears
  51. #  (and before processing the arglist).  If no arglist is supplied, no
  52. #  defaults are applied.  Defaults are obtained by calling WDefault().
  53. #  Icon attribute names are used as option names;  &progname is used
  54. #  as the program name after trimming directories and extensions.
  55. #
  56. #  The following table lists the options recognized in the program arglist,
  57. #  the corresponding attribute (and WDefault()) names, the default values
  58. #  if any, and the meanings.  All legal attributes are allowed in the
  59. #  Window() call, but only these are set from the command line or
  60. #  environment:
  61. #
  62. #    arg    attribute    default        meaning
  63. #    ---    ---------    -------        --------------------------
  64. #    -B    bg        pale gray    background color
  65. #    -F    fg        black        foreground color
  66. #    -T    font         -        text font
  67. #    -L    label        &progname    window title
  68. #                (trimmed)
  69. #
  70. #    -D    display         -        window device
  71. #    -X    posx         -        horizontal position
  72. #    -Y    posy         -        vertical position
  73. #    -W    width        500        window width
  74. #    -H    height        300        window height
  75. #
  76. #    -S    size        500,300        size
  77. #    -P    pos         -        position
  78. #    -G    geometry     -        window size and/or position
  79. #
  80. #    -A    <any>         -        use "-A name=value"
  81. #                        to set arbitrary attribute
  82. #
  83. #    -!     -         -        write open() params to &error
  84. #                        (for debugging)
  85. #
  86. ############################################################################
  87. #
  88. #  Includes:  vdefns
  89. #
  90. ############################################################################
  91. #
  92. #  Requires:  Version 9 graphics
  93. #
  94. ############################################################################
  95.  
  96.  
  97. $include "vdefns.icn"
  98.  
  99. global wdw_debug            # non-null if to trace open call
  100.  
  101.  
  102. #  Window(att, ..., arglist, ..., att) -- open window and set &window
  103.  
  104. procedure Window(args[])
  105.    local cs, pname, att, omit1, omit2, name, val, a, win
  106.    static type
  107.  
  108.    initial type := proc("type", 0)    # protect attractive name
  109.  
  110.    wdw_debug := &null
  111.    att := table()
  112.  
  113.    # Trim &progname for use as option index and window label.
  114.    cs := &cset -- &letters -- &digits -- '.$_'
  115.    &progname ? {
  116.       while tab(upto(cs)) do
  117.          move(1)
  118.       pname := tab(upto('.') | 0)
  119.    }
  120.    if pname == "" then
  121.       pname := &progname
  122.  
  123.    # Process arguments.
  124.    every a := !args do
  125.       case type(a) of {
  126.          "string": a ? {
  127.             name := tab(upto("=")) | runerr(205, a)
  128.             move(1)
  129.             val := tab(0)
  130.             wdw_register(att, name, val)
  131.             }
  132.          "list": {
  133.             wdw_defaults(att, a, pname)
  134.             wdw_options(att, a)
  135.             }
  136.          default:
  137.             runerr(110, a)
  138.          }
  139.  
  140.    # Set defaults for certain attributes if not set earlier.
  141.    /att["fg"] := "black"
  142.    /att["bg"] := VBackground
  143.    /att["label"] := pname
  144.  
  145.    if /att["image"] & not (att["canvas"] === "maximal") then {    # don't override
  146.       /att["width"] := 500
  147.       /att["height"] := 300
  148.       }
  149.  
  150.    # Open the window.  Defer "font" and "fg" until later because they can
  151.    # cause failure.  Don't defer "bg", because it affects the initial
  152.    # window appearance, but try again without it if the open fails.
  153.    omit1 := set(["fg", "font"])
  154.    omit2 := set(["fg", "font", "bg"])
  155.    win := wdw_open(att, omit1 | omit2) | stop(&progname, ": can't open window")
  156.  
  157.    # Set foreground, background, and font, giving a nonfatal message if
  158.    # the value is unacceptable.  Then return the window.
  159.    wdw_attrib(win, att, "fg")
  160.    wdw_attrib(win, att, "bg")
  161.    wdw_attrib(win, att, "font")
  162.    GotoRC(win, 1, 1)            # now that font has been set
  163.    /&window := win
  164.    return win
  165. end
  166.  
  167.  
  168. #  wdw_defaults(att, arglist, pname) -- find defaults and store in att table
  169. #
  170. #  arglist is checked for "-D displayname", which is honored if present.
  171. #  pname is the program name for calling xdefault.
  172. #  A list of several attribute names (see code) is checked.
  173.  
  174. procedure wdw_defaults(att, arglist, pname)
  175.    local w, oname, dpy
  176.  
  177.    # We need to have a window in order to read defaults, and unless we honor
  178.    # the -D option from the command line here it becomes pretty useless.
  179.    dpy := ("display=" || wdw_peekopt(arglist, "D")) | "fg=black"
  180.  
  181.    # Open an offscreen window.
  182.    w := open("Window()", "g", "canvas=hidden", "size=32,32", dpy) |
  183.       stop(&progname, ": can't open display")
  184.  
  185.    # Set attributes from environment.  Order is significant here:
  186.    # pos & size override geometry, and posx/posy/width/height override both.
  187.    every oname := "display" | "bg" | "fg" | "font" | "windowlabel" | "label" |
  188.          "geometry" | "size" | "pos" | "posx" | "posy" | "width" | "height" do
  189.       wdw_register(att, oname, WDefault(w, pname, oname))
  190.  
  191.    # Delete the offscreen window, and return.
  192.    Uncouple(w)
  193.    return
  194. end
  195.  
  196.  
  197. #  wdw_peekopt(arglist, ch) -- return value of option 'ch' from arglist
  198. #
  199. #  Option cracking rules are identical with wdw_options().
  200. #  Fails if the option does not appear.
  201.  
  202. procedure wdw_peekopt(arglist, ch)
  203.    local a, opt, val
  204.  
  205.    arglist := copy(arglist)
  206.    while a := get(arglist) do a ? {
  207.       if ="-" & (opt := tab(any(&ucase))) then {
  208.          if pos(0) then
  209.             val := get(arglist) | fail
  210.          else
  211.             val := tab(0)
  212.          if opt == ch then
  213.             return val
  214.          }
  215.       }
  216.    fail
  217. end
  218.  
  219.  
  220. #  wdw_options(att, arglist) - move options from arglist into att table
  221. #
  222. #  Upper-case options in the argument list are stored in the table "att"
  223. #  under their attribute names (see code for list).  An "option" is a list
  224. #  entry beginning with "-" and an option letter; its value follows in the
  225. #  same string (if more characters remain) or in the next entry.
  226. #
  227. #  This procedure can be "fooled" if a non-upper-case option is followed
  228. #  in the next entry by a value that looks like the start of an option.
  229. #
  230. #  Options and values are removed from arglist, leaving only the unprocessed
  231. #  entries.
  232. #
  233. #  The special option "-!" takes no value and causes wdw_debug to be set.
  234.  
  235. procedure wdw_options(att, arglist)
  236.    local a, opt, name, val, rejects
  237.  
  238.    rejects := []
  239.    while a := get(arglist) do a ? {
  240.       if ="-" & (opt := tab(any(&ucase))) then {
  241.          if pos(0) then
  242.             val := get(arglist) | stop(&progname, ": missing value for ", a)
  243.          else
  244.             val := tab(0)
  245.          case opt of {
  246.             "B":  wdw_register(att, "bg", val)
  247.             "F":  wdw_register(att, "fg", val)
  248.             "T":  wdw_register(att, "font", val)
  249.             "L":  wdw_register(att, "label", val)
  250.             "D":  wdw_register(att, "display", val)
  251.             "X":  wdw_register(att, "posx", val)
  252.             "Y":  wdw_register(att, "posy", val)
  253.             "W":  wdw_register(att, "width", val)
  254.             "H":  wdw_register(att, "height", val)
  255.             "P":  wdw_register(att, "pos", val)
  256.             "S":  wdw_register(att, "size", val)
  257.             "G":  wdw_register(att, "geometry", val)
  258.             "A":  val ? {
  259.                name := tab(upto("=")) |
  260.                   stop(&progname, ": malformed -A option: ", val)
  261.                move(1)
  262.                wdw_register(att, name, tab(0))
  263.                }
  264.             default:  stop(&progname, ": unrecognized option -", opt)
  265.             }
  266.          }
  267.       else if ="-!" & pos(0) then
  268.          wdw_debug := 1
  269.       else
  270.          put(rejects, a)
  271.       }
  272.  
  273.    # Arglist is now empty; put back args that we didn't use.
  274.    while put(arglist, get(rejects))
  275.    return
  276. end
  277.  
  278.  
  279.  
  280. #  wdw_register(att, name, val) -- store attribute val in att[name]
  281. #
  282. #  The compound attributes "pos", "size",  and "geometry" are broken down
  283. #  into their component parts and stored as multiple values.  A runtime
  284. #  error occurs if any of these is malformed.  Interactions with
  285. #  "canvas=maximal" are also handled.
  286.  
  287. procedure wdw_register(att, name, val)
  288.    wdw_reg(att, name, val) | runerr(205, name || "=" || val)
  289.    return
  290. end
  291.  
  292. procedure wdw_reg(att, name, val)
  293.    case name of {
  294.       "size": val ? {        # size=www,hhh
  295.          att["width"] := tab(many(&digits)) | fail
  296.          ="," | fail
  297.          att["height"] := tab(many(&digits)) | fail
  298.          pos(0) | fail
  299.          if \att["canvas"] == "maximal" then
  300.             delete(att, "canvas")
  301.          }
  302.       "pos": val ? {        # pos=xxx,yyy
  303.          att["posx"] := tab(many(&digits)) | fail
  304.          ="," | fail
  305.          att["posy"] := tab(many(&digits)) | fail
  306.          pos(0) | fail
  307.          }
  308.       "geometry": val ? {    # geometry=[wwwxhhh][+xxx+yyy]
  309.          if att["width"] := tab(many(&digits))
  310.          then {
  311.             ="x" | fail
  312.             att["height"] := tab(many(&digits)) | fail
  313.             if \att["canvas"] == "maximal" then
  314.                delete(att, "canvas")
  315.             }
  316.          if ="+" then {
  317.             att["posx"] := tab(many(&digits)) | fail
  318.             ="+" | fail
  319.             att["posy"] := tab(many(&digits)) | fail
  320.             }
  321.          pos(0) | fail
  322.          }
  323.       "canvas": {
  324.          att[name] := val
  325.          if val == "maximal" then
  326.             every delete(att, "width" | "height")
  327.          }
  328.       default: {
  329.          att[name] := val
  330.          }
  331.       }
  332.    return
  333. end
  334.  
  335.  
  336. #  wdw_open(att, omit) -- open window with attributes from att table
  337. #
  338. #  Ignore null or empty attributes and those in the "omit" set.
  339. #  Trace open call if wdw_debug is set.  Set &window.
  340.  
  341. procedure wdw_open(att, omit)
  342.    local args, name
  343.    static image
  344.  
  345.    initial image := proc("image", 0)    # protect attractive name
  346.  
  347.    args := [&progname, "g"]
  348.    every name := key(att) do
  349.       if not member(omit, name) then
  350.          put(args, name || "=" || ("" ~== \att[name]))
  351.  
  352.    if \wdw_debug then {
  353.       writes(&errout, "Window: open(", image(args[1]))
  354.       every writes(&errout, ",", image(args[2 to *args]))
  355.       write(&errout, ")")
  356.       }
  357.  
  358.    return open ! args
  359. end
  360.  
  361.  
  362. #  wdw_attrib(win, att, name) -- call WAttrib(win, name=att[name])
  363. #
  364. #  Null and empty values are ignored.
  365. #  Failure is diagnosed on stderr.
  366. #  The call is traced if wdw_debug is set.
  367.  
  368. procedure wdw_attrib(win, att, name)
  369.    local val, s
  370.    static image
  371.  
  372.    initial image := proc("image", 0)    # protect attractive name
  373.  
  374.    val := ("" ~== \att[name]) | return
  375.    s := name || "=" || val
  376.    if \wdw_debug then
  377.       write(&errout, "Window: WAttrib(", image(s), ")")
  378.    WAttrib(win, s) | write(&errout, &progname, ": can't set ", s)
  379.    return
  380. end
  381.