tpm@eng.cam.ac.uk (tim marsland) (04/11/90)
Hi. We're trying to use icons from the FileManager with a NeWS client
(4.0.3c, OpenWindows 1.0fcs). Specifically we're trying to get the
pathname of file when the cursor-icon that represents it is dropped onto a
NeWS canvas. So far, despite valiant efforts, we've managed to detect a
GrabEnterNotify sent to the canvas, but its /Action field is simply an
integer. Presumably we have to register an interest with the FileManager
to tell it that we`re prepared to handle the drop, but we can find no
mention of how to do this (or anything else to do with using the
FileManager in this way!) in the documentation.
Has anyone managed to make a NeWS client interact properly with the
FileManager? Please mail me, and I'll post a summary.
tim marsland
P.S. Anyone seen a [good] class browser for XNeWS? .. it's really very
tiring when trying to understand the behaviour of a class hierarchy.bvs@SUN.COM (Bruce V. Schwartz - Marketing Technical Support) (04/12/90)
Date: Wed, 11 Apr 90 17:05:50 -0400
To: NeWS-makers@brillig.umd.edu
Subject: Using the FileManager with NeWS
From: mcsun!ukc!cam-eng!!tpm@uunet.uu.net (tim marsland)
Sender: NeWS-makers-request@brillig.umd.edu (Don Hopkins)
Return-Path: NeWS-makers-request@brillig.umd.edu (Don Hopkins)
Message-Id: <5947@rasp.eng.cam.ac.uk>
Status: RO
P.S. Anyone seen a [good] class browser for XNeWS? .. it's really very
tiring when trying to understand the behaviour of a class hierarchy.
Here's a class browser for XNeWS. You can decide if it's any good.
-Bruce Schwartz
Sun Microsystems
#!/bin/sh
#
# This file is a product of Sun Microsystems, Inc. and is provided for
# unrestricted use provided that this legend is included on all tape
# media and as a part of the software program in whole or part. Users
# may copy or modify this file without charge, but are not authorized to
# license or distribute it to anyone else except as part of a product
# or program developed by the user.
#
# THIS FILE IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE
# WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
# PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE.
#
# This file is provided with no support and without any obligation on the
# part of Sun Microsystems, Inc. to assist in its use, correction,
# modification or enhancement.
#
# SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE
# INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY THIS FILE
# OR ANY PART THEREOF.
#
# In no event will Sun Microsystems, Inc. be liable for any lost revenue
# or profits or other special, indirect and consequential damages, even
# if Sun has been advised of the possibility of such damages.
#
# Sun Microsystems, Inc.
# 2550 Garcia Avenue
# Mountain View, California 94043
#
# (c) 1988, 1989, 1990 Sun Microsystems
#
psh << EOF
%
% This file contains a NeWS server class browser.
%
% The browser is built on the classes defined in pw.ps. The class
% browser has 5 panes. It is similar in appearance to the Smalltalk
% browser. The first pane on the top of the window contains the list of
% classes in the server. The next 3 contain the list of methods, class
% variables, and instance variables associated with the selected class in
% the first pane. The bottom pane is used to display information about
% the current selection.
%
% This code was mostly written in August 1987 but was revised to work with
% NeWS 1.1 in May 1988.
%
% Many changes in November 1988. Integrated several of Richard Hess's
% improvements. New features include improved scrolling, caching of browsed
% classes, addition of the NoClass class for browsing the systemdict, better
% decompilation of dictionaries, and process control (new request cancels
% previous, better error handling, and looks better on B/W screen.
%
% Bruce V. Schwartz
% Sun Microsystems
% bvs@sun.com
%
% Reworked June 1989 to work with OpenWindows 1.0beta2
% Reworked March 1990 to work with OpenWindows 2.0beta
% This file contains the classes used by the class browser.
% The classes included are:
% Picture -- an Item similar in concept to the NeWS1.1 textcanvas
% PicWindow -- a LiteWindow that holds Pictures
% PicScroll -- a SimpleScrollbar with a few modifications (auto scrolling)
%
% This code was mostly written in August 1987 but was revised to work with
% NeWS 1.1 in May 1988.
%
% Bruce V. Schwartz
% Sun Microsystems
% bvs@sun.com
%
systemdict begin
systemdict /Item known not { (NeWS/liteitem.ps) run } if
systemdict /SimpleScrollbar known not { (NeWS/liteitem.ps) run } if
end
%% This file contains classes: PicWindow Picture PicScroll
/PicWindow LiteWindow
dictbegin
/PicArray [] def
dictend
classbegin
/BorderRight 1 def
/BorderLeft 1 def
/BorderBottom 1 def
/PaintIcon
{
1 fillcanvas
0 strokecanvas
.8 setgray
IconWidth 2 div 1 sub IconHeight 4 div 5 sub 5 Sunlogo
0 setgray
IconWidth 2 div 3 moveto (Browse!) cshow
} def
/PaintClient
{
%% (paint client %\n) [ PicArray ] dbgprintf
%% PicArray { ( %\n) [ 3 2 roll ] dbgprintf } forall
PicArray paintitems
} def
/setpicarray
{
/PicArray exch def
} def
/destroy
{
%% (destroying arrays\n) [] dbgprintf
PicArray { /destroy exch send } forall
%% (destroying window\n) [] dbgprintf
/destroy super send
%% (destroyed window\n) [] dbgprintf
} def
% OPEN LOOK-ize: use select button to move window
/CreateFrameInterests { % - => - (Create frame control interests)
/CreateFrameInterests super send
FrameInterests
begin
/FrameMoveEvent
PointButton {/slide self send pause /totop self send pop}
/DownTransition FrameCanvas eventmgrinterest def
FrameMoveEvent /Exclusivity true put
/FrameAdjustEvent
AdjustButton {pop}
null FrameCanvas eventmgrinterest def
FrameAdjustEvent /Exclusivity true put
end
} def
/CreateIconInterests { % - => - (Create icon control interests)
/CreateIconInterests super send
FrameInterests begin
/IconOpenEvent null def
/IconMoveEvent
PointButton {/slide self send pause /totop self send pop}
/DownTransition IconCanvas eventmgrinterest def
IconMoveEvent /Exclusivity true put
/IconAdjustEvent
AdjustButton {pop}
null IconCanvas eventmgrinterest def
IconAdjustEvent /Exclusivity true put
end
} def
/flipiconic { % - => - (swaps between open & closed)
/unmap self send
/Iconic? Iconic? not def
IconX null eq {
FrameX FrameY FrameHeight add IconHeight sub /move self send
} if
ZoomProc
/totop self send
/map self send
} def
classend
def
/PicScrollbar SimpleScrollbar
dictbegin
/Owner null def
/LastX null def
/LastY null def
dictend
classbegin
/ItemShadeColor .5 def
/setowner {
/Owner exch def
} def
/ClientDown {
/ClientDown super send
} def
/ClientUp { % - => -
/ClientUp super send
ItemValue ItemInitialValue ne { /Notify Owner send } if
} def
/PaintBar { } def
/EraseBox { } def
/PaintButtons {
BarViewPercent 1 gt
true or
{ /PaintButtons super send } if
} def
/PaintBox { % - => - (paint box)
%(PaintBox %\n) [ BarViewPercent ] dbgprintf
%(pause...) [] dbgprintf 1 60 div sleep (!!\n) [] dbgprintf
gsave
10 dict begin
/x 1 def
/w ItemWidth 1 sub def
BarViewPercent 1 le
{
1 setgray
x ButtonSize w ItemHeight ButtonSize dup add sub rectpath fill
}
{
1 1 BarViewPercent div sub 1 ItemValue sub mul
ItemHeight ButtonSize dup add sub mul ButtonSize add
/y exch def
1 BarViewPercent div ItemHeight ButtonSize dup add sub mul
/h exch def
%
% do the normal bar
%
ItemFillColor setcolor
x ButtonSize w y ButtonSize sub rectpath fill
x y h add w ItemHeight ButtonSize sub y sub h sub rectpath fill
%
% do the big scroll box
%
/ybut ItemValue ValueToY def
ItemShadeColor setgray
x y w ybut y sub rectpath fill
x ybut ButtonSize add
w h ButtonSize sub ybut sub y add rectpath fill
%
% do the little scroll box
%
ItemValue BoxPath
BoxFillColor setcolor gsave fill grestore
} ifelse
end
/ItemPaintedValue ItemValue def
grestore
/Notify Owner send
} def
/HiliteItem {
ScrollMotion
{
/ScrollAbsolute { }
/ScrollPageForward { }
/ScrollPageBackward { }
/ScrollLineForward % top
{
0 ItemHeight ButtonSize ButtonSize neg rectpath
5 setrasteropcode fill
}
/ScrollLineBackward % bottom
{
0 0 ButtonSize ButtonSize rectpath
5 setrasteropcode fill
}
} case
} def
/UnhiliteItem {
gsave
ScrollMotion
{
/ScrollAbsolute {}
/ScrollPageForward {}
/ScrollPageBackward {}
/ScrollLineForward % top
{
0 ItemHeight ButtonSize sub ButtonSize ButtonSize rectpath
clip
PaintButtons
}
/ScrollLineBackward % bottom
{
0 0 ButtonSize ButtonSize rectpath
clip
PaintButtons
}
} case
grestore
} def
classend
def
/Picture Item
dictbegin
/BufferCanvas null def
/BufferWidth 0 def
/BufferHeight 0 def
/HScrollbar null def
/VScrollbar null def
/HScrollbar? true def
/VScrollbar? true def
/HScrollWidth 0 def
/VScrollWidth 0 def
/ScrollWidth 16 def
/NotifyUserDown { pop pop } def % x y => -
/NotifyUserUp { pop pop } def % x y => -
/NotifyUserDrag { pop pop } def % x y => -
/NotifyUserEnter { pop pop } def % x y => -
/NotifyUserExit { pop pop } def % x y => -
dictend
classbegin
/new { % parentcanvas width height => instance
% (new begin\n) [] dbgprintf
/new super send
begin
/BufferHeight ItemHeight def
/BufferWidth ItemWidth def
CreateScrollbars
CreateBuffer
currentdict
end
% (new end\n) [] dbgprintf
} def
/destroy {
HScrollbar null ne { null /setowner HScrollbar send } if
VScrollbar null ne { null /setowner VScrollbar send } if
%% BufferCanvas /Mapped false put
%% /BufferCanvas null def
} def
/reshape { % x y w h => -
/reshape super send
ReshapeScrollbars
} def
/reshapebuffer { % w h => -
/BufferHeight exch
ItemHeight HScrollbar? { HScrollWidth sub } if max def
/BufferWidth exch
ItemWidth VScrollbar? { VScrollWidth sub } if max def
ReshapeBuffer
%ReshapeScrollbars
AdjustScrollbars
} def
/getcanvas {
BufferCanvas
} def
/updatecanvas {
PaintBuffer
} def
/makestartinterests {
/makestartinterests HScrollbar send
/makestartinterests VScrollbar send
[ exch aload length 2 add -1 roll aload pop ] % join 2 arrays
/makestartinterests super send
[ exch aload length 2 add -1 roll aload pop ] % join 2 arrays
} def
/PaintItem {
%% (PaintItem begin\n) [] dbgprintf
PaintBuffer
/paint VScrollbar send
/paint HScrollbar send
%% (PaintItem end\n) [] dbgprintf
} def
/Notify {
% (picture got notified\n) [] dbgprintf
NotifyUser
PaintBuffer
} def
/PaintBuffer {
% (PaintBuffer begin \n) [ ] dbgprintf
gsave
ItemCanvas setcanvas
%
% Stroke canvas
%
0 setgray
0
HScrollWidth
ItemWidth VScrollWidth sub
ItemHeight HScrollWidth sub
rectpath
stroke
%
% compute clipping region
%
1
HScrollWidth 1 add
ItemWidth VScrollWidth sub 2 sub
ItemHeight HScrollWidth sub 2 sub
rectpath
% (clip to % % % %\n) [ pathbbox ] dbgprintf
clip
%
% compute translation
%
BufferWidth ItemWidth sub VScrollWidth add neg
dup 0 lt
{
1 /getvalue HScrollbar send sub
mul
}
{ pop 0 } ifelse
BufferHeight ItemHeight sub HScrollWidth add neg
dup 0 lt
{
1 /getvalue VScrollbar send sub
mul
}
{ } ifelse
HScrollWidth add
% 2 copy (translate by % %\n) [ 4 2 roll ] dbgprintf
translate
% XNeWS fix
% BufferWidth BufferHeight
% 2 copy (scale by % %\n) [ 4 2 roll ] dbgprintf
% scale
% (currentmatrix % % % % % %\n) [ matrix currentmatrix aload pop ] dbgprintf
pause
BufferCanvas imagecanvas
pause
grestore
% (PaintBuffer end\n) [ ] dbgprintf
} def
/CreateBuffer { % - => -
/BufferCanvas framebuffer newcanvas def
BufferCanvas /Retained true put
BufferCanvas /Mapped false put
ReshapeBuffer
} def
/ReshapeBuffer { % - => -
gsave
framebuffer setcanvas
0 0 BufferWidth BufferHeight
rectpath
BufferCanvas reshapecanvas
grestore
} def
/CreateScrollbars { % - => -
% (begin CreateScrollbars\n) [] dbgprintf
/HScrollWidth HScrollbar? { ScrollWidth } { 0 } ifelse def
/VScrollWidth VScrollbar? { ScrollWidth } { 0 } ifelse def
ItemWidth VScrollWidth le { /VScrollWidth ScrollWidth 2 div def } if
ItemHeight HScrollWidth le { /HScrollWidth ScrollWidth 2 div def } if
/HScrollbar
[1 0 .01 .1 BufferWidth ItemWidth VScrollWidth sub div ]
1 {} ItemCanvas
/new PicScrollbar send
dup /BarVertical? false put
def
/VScrollbar
[1 0 .01 .1 BufferHeight ItemHeight HScrollWidth sub div ]
1 {} ItemCanvas
/new PicScrollbar send
def
self /setowner HScrollbar send
self /setowner VScrollbar send
% (end CreateScrollbars\n) [] dbgprintf
} def
% Set the range for the scrollbars
%
/AdjustScrollbars {
[1 0 .01 .1 BufferWidth ItemWidth VScrollWidth sub div ]
/setrange HScrollbar send
[1 0 .01 .1 BufferHeight ItemHeight HScrollWidth sub div ]
/setrange VScrollbar send
} def
/ReshapeScrollbars {
/HScrollWidth HScrollbar? { ScrollWidth } { 0 } ifelse def
/VScrollWidth VScrollbar? { ScrollWidth } { 0 } ifelse def
AdjustScrollbars
10 dict begin
/h ItemHeight def /w ItemWidth def
/s ScrollWidth def
HScrollbar?
{ 0 0 w VScrollWidth sub s }
{ 0 0 0 0 }
ifelse
% 4 copy (hscroll % % % %\n) [ 6 2 roll ] dbgprintf
/reshape HScrollbar send
VScrollbar?
{ w s sub HScrollWidth s h HScrollWidth sub }
{ 0 0 0 0 }
ifelse
% 4 copy (vscroll % % % %\n) [ 6 2 roll ] dbgprintf
/reshape VScrollbar send
end
} def
/ClientDown {
% (Picture ClientDown\n) [] dbgprintf
% compute translation
%
BufferWidth ItemWidth sub VScrollWidth add neg
dup 0 lt
{
1 /getvalue HScrollbar send sub
mul
}
{ pop 0 } ifelse
BufferHeight ItemHeight sub HScrollWidth add neg
dup 0 lt
{
1 /getvalue VScrollbar send sub
mul
}
{ } ifelse
HScrollWidth add
% translatex translatey
CurrentEvent /YLocation get sub neg exch
CurrentEvent /XLocation get sub neg exch
% (n: %\n) [ NotifyUserDown ] dbgprintf
{ NotifyUserDown } fork
} def
/ClientUp {
% (Picture ClientUp\n) [] dbgprintf
CurrentEvent begin XLocation YLocation end
NotifyUserUp
} def
/ClientDrag {
% (client drag\n) [] dbgprintf
CurrentEvent begin XLocation YLocation end
NotifyUserDrag
} def
/ClientEnter {
%% (client enter\n) [] dbgprintf
CurrentEvent begin XLocation YLocation end NotifyUserEnter
} def
/ClientExit {
%% (client exit\n) [] dbgprintf
CurrentEvent begin XLocation YLocation end NotifyUserExit
} def
classend
def
%%%%%%%%%%%%%%%%Browser code%%%%%%%%%%%%%%%
/Font15 /Times-Roman findfont 15 scalefont def
/PickProcess null def
/PicArray [ ] def
/win framebuffer /new PicWindow send def
{
/FrameLabel (Class Browser for X11/NeWS) def
} /doit win send
/can win /ClientCanvas get def
/LastClassPick null def
/LastInstPick null def
/LastMethodPick null def
/LastVarPick null def
/ClassKeys [] def
/InstKeys [] def
/MethodKeys [] def
/VarKeys [] def
/W 200 def
/H 300 def
/TextW 800 def
/TextH 300 def
100 100 TextW TextH H add 16 add /reshape win send
/ClassPic win /ClientCanvas get W H /new Picture send def % classes
/MethodPic win /ClientCanvas get W H /new Picture send def % methods
/VarPic win /ClientCanvas get W H /new Picture send def % class var
/InstPic win /ClientCanvas get W H /new Picture send def % ints var
/TextPic win /ClientCanvas get TextW TextH /new Picture send def % text
/PicArray [ ClassPic InstPic MethodPic VarPic TextPic ] def
PicArray /setpicarray win send
ClassPic /HScrollbar? false put
InstPic /HScrollbar? false put
MethodPic /HScrollbar? false put
VarPic /HScrollbar? false put
TextPic /HScrollbar? false put
000 TextH W H /reshape ClassPic send
200 TextH W H /reshape MethodPic send
400 TextH W H /reshape VarPic send
600 TextH W H /reshape InstPic send
0 0 TextW TextH /reshape TextPic send
0 /setvalue ClassPic /VScrollbar get send pop % pop the null ret value
0 /setvalue InstPic /VScrollbar get send pop % pop the null ret value
0 /setvalue MethodPic /VScrollbar get send pop % pop the null ret value
0 /setvalue VarPic /VScrollbar get send pop % pop the null ret value
0 /setvalue TextPic /VScrollbar get send pop % pop the null ret value
ColorDisplay?
{
/ClassColor 1 .8 .8 rgbcolor def
/InstColor 1 .8 1 rgbcolor def
/MethodColor .8 1 .8 rgbcolor def
/VarColor .8 .8 1 rgbcolor def
/TextColor 1 1 1 rgbcolor def
}
{
/ClassColor 1 1 1 rgbcolor def
/InstColor 1 1 1 rgbcolor def
/MethodColor 1 1 1 rgbcolor def
/VarColor 1 1 1 rgbcolor def
/TextColor 1 1 1 rgbcolor def
} ifelse
ClassPic /NotifyUserDown { { ClassPick } HandlePick } put
InstPic /NotifyUserDown { { InstPick } HandlePick } put
MethodPic /NotifyUserDown { { MethodPick } HandlePick } put
VarPic /NotifyUserDown { { VarPick } HandlePick } put
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Utilities for expanding NeWS object types
/String256 256 string def
/Expand % thing -> -
{
ExpandDict begin
10 dict begin
/ArrayDepth 0 def
/TabWidth ( ) stringwidth pop def
() exch dup type exec
end end
} def
/StartArray % string array -> string (string) array
{
/tmparray exch def
StartLine
([) AddString
/tmparray load
/ArrayDepth ArrayDepth 1 add def
} def
/EndArray % string -> string (string)
{
/ArrayDepth ArrayDepth 1 sub def
(] ) append
StartLine
} def
/StartXArray % string array -> string (string) array
{
/tmparray exch def
StartLine
({) AddString
/tmparray load
/ArrayDepth ArrayDepth 1 add def
} def
/EndXArray % string -> string (string)
{
/ArrayDepth ArrayDepth 1 sub def
(} ) append
StartLine
} def
/StartLine % string -> string (string)
{
dup stringwidth pop TabWidth ArrayDepth mul gt {
() ArrayDepth { ( ) append } repeat
} if
} def
/AddString % string string -> string (string)
{
append ( ) append
dup stringwidth pop 700 gt { StartLine } if
pause
} def
/ExpandDict
35 dict begin
/arraytype
%% Should handle auto-loaded classes here
{ dup xcheck
{ StartXArray { dup type exec } forall EndXArray }
{ StartArray { dup type exec } forall EndArray }
ifelse } def
/packedarraytype //arraytype def
/dicttype % note that this is overridden below
{
dup /ClassName known
{
/ClassName get String256 cvs AddString
}
{
/tmp exch def
StartLine (<<Dictionary Begin>>) AddString StartLine
tmp
{
/tmp exch def dup type exec
( ) AddString
/tmp load dup type exec
StartLine
} forall
StartLine (<<Dictionary END>>) AddString StartLine
} ifelse
} def
% /dicttype
% {
% dup /ClassName known
% {
% /ClassName get
% } if
% String256 cvs AddString
% } def
/booleantype { String256 cvs AddString} def
/filetype { String256 cvs AddString} def
/fonttype { String256 cvs AddString} def
/integertype { String256 cvs AddString} def
/marktype { ([ ) AddString} def
/nametype { dup String256 cvs
exch xcheck not { (/) exch append } if AddString } def
/nulltype { String256 cvs AddString} def
/operatortype { String256 cvs
dup length 2 sub 1 exch getinterval AddString} def
/realtype { String256 cvs AddString} def
/savetype { String256 cvs AddString} def
/stringtype { String256 cvs
(\() exch append (\)) append AddString} def
%% NeWS types
/vmtype { String256 cvs AddString} def
/canvastype { String256 cvs AddString} def
/colortype { String256 cvs AddString} def
/eventtype { String256 cvs AddString} def
/graphicsstatetype { String256 cvs AddString} def
/monitortype { String256 cvs AddString} def
/processtype { String256 cvs AddString} def
/shapetype { String256 cvs AddString} def
currentdict end
def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Sorting Utilities
/FindSmall % proc array -> int
{ 10 dict begin
/a exch def
/proc exch def
/result 0 def
/key a 0 get def
/i 0 def
0 1 a length 1 sub
{
/j exch def
key a j get proc
{
/i j def
/key a j get def
} if
} for
i
end } def
/FasterSort % proc array -> array
{ 10 dict begin
/arrayin exch def
/arrayout [] def
/proc exch def
{
arrayin length 0 eq { arrayout exit } if
/proc load arrayin FindSmall
/i exch def
arrayout arrayout length arrayin i get
arrayinsert
/arrayout exch def
/arrayin arrayin i arraydelete def
pause
} loop
end } def
/Sort % array -> array
{
{ gt } exch FasterSort
} def
/BubbleSort % array -> array
{
20 dict begin
/keys exch def
/bound keys length 1 sub def
/check 0 def
{
/t -1 def
0 1 bound 1 sub
{
/i exch def
/j i 1 add def
/keysi keys i get def
/keysj keys j get def
keysi keysj gt
{
keys i keysj put
keys j keysi put
/t j def
} if
} for
t -1 eq
{ exit }
{ /bound t def }
ifelse
pause
} loop
keys
end
%% EndWait
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Main Class code
/ShowArray { % array color pic
% (showarray: count %\n) [ count ] dbgprintf
10 dict begin
/pic exch def
/color exch def
/a exch def
Font15 setfont
W a length 18 mul 15 add /reshapebuffer pic send
% { /paint VScrollbar send /paint HScrollbar send } pic send
/getcanvas pic send setcanvas
color fillcanvas
mark
/PaintItem pic send
cleartomark % PaintItem seems to leave 2 things on the stack
0 0 0 rgbcolor setcolor
/k pic /BufferHeight get def
a
{
/k k 18 sub def
5 k
moveto
show
} forall
/updatecanvas pic send
end
} def
/DoClasses {
[
systemdict
{
/val exch cvlit def
/key exch cvlit def
val type /dicttype eq
{
val /ClassName known
{
key val /ClassName get eq
{
% leave this on the stack
key 256 string cvs
} if
} if
} if
pause
} forall
]
Sort
userdict begin /ClassKeys exch def end
ClassKeys ClassColor ClassPic ShowArray
userdict /ClassesDict ClassKeys length dict put
[] MethodColor MethodPic ShowArray
[] VarColor VarPic ShowArray
[] InstColor InstPic ShowArray
[] TextColor TextPic ShowArray
% fork off a process to fill the ClassesDict for
% all classes
% { ClassKeys { DoClass } forall } fork
} def
/DoClass % classname -> - (sorts all class attributes)
{ 10 dict begin
/classname exch def
ClassesDict classname known not
{
/classarrays 3 dict def
/classdict systemdict classname get def
classdict GetSortedMethods
classdict GetSortedClassVars
classdict GetSortedInstVars
classarrays begin
/InstVars exch def
/ClassVars exch def
/Methods exch def
end
ClassesDict classname classarrays put
} if
end } def
/GetSortedMethods { % classdict => -
[ exch
{
/val exch def
/key exch def
/val load type dup
/arraytype eq exch
/packedarraytype eq or
/val load xcheck
and
{
key 256 string cvs
}
if
pause
} forall
]
Sort
} def
/GetSortedClassVars { % classdict => -
[ exch
{
/val exch def
/key exch def
/val load type
{
/arraytype
/packedarraytype
{ /val load xcheck not }
/operatortype { false }
/dicttype { /val load /ClassName known not }
/Default { true }
} case
{
key 256 string cvs
}
if
pause
} forall
]
Sort
} def
/GetSortedInstVars { % classdict => -
[ exch /InstanceVars get
dup null eq { pop [] } if
{
/val exch def
/key exch def
key 256 string cvs
pause
} forall
]
Sort
} def
/DoMethods % classname => -
{
ClassesDict exch get /Methods get
userdict begin /MethodKeys exch def end
MethodKeys MethodColor MethodPic ShowArray
} def
/DoVars % classname => -
{
ClassesDict exch get /ClassVars get
userdict begin /VarKeys exch def end
VarKeys VarColor VarPic ShowArray
} def
/DoInsts % classname => -
{
ClassesDict exch get /InstVars get
userdict begin /InstKeys exch def end
InstKeys InstColor InstPic ShowArray
} def
/ClassPick % x y => -
{
10 dict begin
/y exch def
/x exch def
/k ClassPic /BufferHeight get y sub 18 div floor cvi def
/lastpick LastClassPick def
userdict /LastClassPick k put
Font15 setfont
lastpick null ne
{
null SetMethodPick
null SetVarPick
null SetInstPick
gsave
%(unhilite %\n) [ lastpick ] dbgprintf
/getcanvas ClassPic send setcanvas
0 ClassPic /BufferHeight get
lastpick 1 add 18 mul sub 3 sub W 18 rectpath
ClassColor setcolor fill
0 0 0 rgbcolor setcolor
5 ClassPic /BufferHeight get
lastpick 1 add 18 mul sub moveto ClassKeys
lastpick get show
grestore
} if
lastpick null ne
lastpick k ne
and
{
%% put scroll bars back to top
0 /setvalue InstPic /VScrollbar get send
0 /setvalue MethodPic /VScrollbar get send
0 /setvalue VarPic /VScrollbar get send
0 /setvalue TextPic /VScrollbar get send
} if
%(pick is % \n ) [ k ] dbgprintf
k ClassKeys length 1 sub le
{
% (pick is % '%' \n ) [ ClassKeys k get k ] dbgprintf
% (Lastpick was '%' \n ) [ lastpick ] dbgprintf
/getcanvas ClassPic send setcanvas
% (hilite %\n) [ k ] dbgprintf
0 ClassPic /BufferHeight get k 1 add 18 mul sub 3 sub W 18 rectpath
0 0 0 rgbcolor setcolor fill
ClassColor setcolor
0 5 ClassPic /BufferHeight get
k 1 add 18 mul sub moveto ClassKeys k get show
/updatecanvas ClassPic send
lastpick k ne
{
[(Loading Menus...)] TextColor TextPic ShowArray
[] MethodColor MethodPic ShowArray
[] VarColor VarPic ShowArray
[] InstColor InstPic ShowArray
ClassKeys k get cvn
dup DoClass
dup DoMethods
dup DoVars
dup DoInsts
pop
} if
[
(CLASS ") ClassKeys k get 256 string cvs (") append append
systemdict ClassKeys k get cvn get /ParentDictArray known
{
systemdict ClassKeys k get cvn get /ParentDictArray get
{
/ClassName get 256 string cvs ( ) exch append
} forall
} if
]
TextColor TextPic ShowArray
k
}
{
/updatecanvas ClassPic send
null
} ifelse
end
} def
/SetInstPick % newpick => -
{
10 dict begin
Font15 setfont
LastInstPick null ne
{
gsave
/getcanvas InstPic send setcanvas
0 InstPic /BufferHeight get
LastInstPick 1 add 18 mul sub 3 sub W 18 rectpath
InstColor setcolor fill
0 0 0 rgbcolor setcolor
5 InstPic /BufferHeight get LastInstPick 1 add 18 mul sub moveto
InstKeys LastInstPick get show
grestore
} if
userdict begin /LastInstPick exch def end % pick up newpick
%% (new InstPick is % \n ) [ LastInstPick ] dbgprintf
LastInstPick null ne
{
/getcanvas InstPic send setcanvas
0 InstPic /BufferHeight get
LastInstPick 1 add 18 mul sub 3 sub W 18 rectpath
0 0 0 rgbcolor setcolor fill
InstColor setcolor
0 5 InstPic /BufferHeight get
LastInstPick 1 add 18 mul sub moveto
InstKeys LastInstPick get show
} if
/updatecanvas InstPic send
LastInstPick null ne
{
/val
systemdict ClassKeys LastClassPick get cvn get % class
/InstanceVars get % instdict
InstKeys LastInstPick get % class variable
get
def
[] TextColor TextPic ShowArray
[
(INSTANCE VARIABLE)
( ") InstKeys LastInstPick get 256 string cvs (")
append append append
val Expand
] TextColor TextPic ShowArray
} if
end
} def
/InstPick
{
null SetMethodPick
null SetVarPick
10 dict begin
/y exch def
/x exch def
/k InstPic /BufferHeight get y sub 18 div floor cvi def
%% (pick is % \n ) [ k ] dbgprintf
k dup
end
InstKeys length 1 sub le
{ SetInstPick }
{ pop }
ifelse
} def
/SetMethodPick % newpick => -
{
Font15 setfont
LastMethodPick null ne
{
gsave
/getcanvas MethodPic send setcanvas
0 MethodPic /BufferHeight get
LastMethodPick 1 add 18 mul sub 3 sub W 18 rectpath
MethodColor setcolor fill
0 0 0 rgbcolor setcolor
5 MethodPic /BufferHeight get
LastMethodPick 1 add 18 mul sub moveto
MethodKeys LastMethodPick get show
grestore
} if
userdict begin /LastMethodPick exch def end % pick up newpick
%% (new MethodPick is % \n ) [ LastMethodPick ] dbgprintf
LastMethodPick null ne
{
/getcanvas MethodPic send setcanvas
0 MethodPic /BufferHeight get
LastMethodPick 1 add 18 mul sub 3 sub W 18 rectpath
0 0 0 rgbcolor setcolor fill
MethodColor setcolor
0 5 MethodPic /BufferHeight get
LastMethodPick 1 add 18 mul sub moveto
MethodKeys LastMethodPick get show
} if
/updatecanvas MethodPic send
LastMethodPick null ne
{
[] TextColor TextPic ShowArray
[
(METHOD ") MethodKeys LastMethodPick get
256 string cvs (") append append
systemdict ClassKeys LastClassPick get cvn get % class
MethodKeys LastMethodPick get % class method
get
Expand
] TextColor TextPic ShowArray
} if
} def
/MethodPick
{
null SetVarPick
null SetInstPick
10 dict begin
/y exch def
/x exch def
/k MethodPic /BufferHeight get y sub 18 div floor cvi def
%% (pick is % \n ) [ k ] dbgprintf
k dup
end
MethodKeys length 1 sub le
{ SetMethodPick }
{ pop }
ifelse
} def
/SetVarPick % newpick => -
{
10 dict begin
Font15 setfont
LastVarPick null ne
{
gsave
/getcanvas VarPic send setcanvas
0 VarPic /BufferHeight get
LastVarPick 1 add 18 mul sub 3 sub W 18 rectpath
VarColor setcolor fill
0 0 0 rgbcolor setcolor
5 VarPic /BufferHeight get
LastVarPick 1 add 18 mul sub moveto
VarKeys LastVarPick get show
grestore
} if
userdict begin /LastVarPick exch def end % pick up newpick
%% (new VarPick is % \n ) [ LastVarPick ] dbgprintf
LastVarPick null ne
{
/getcanvas VarPic send setcanvas
%(hilite %\n) [ LastVarPick ] dbgprintf
0 VarPic /BufferHeight get
LastVarPick 1 add 18 mul sub 3 sub W 18 rectpath
0 0 0 rgbcolor setcolor fill
VarColor setcolor
0 5 VarPic /BufferHeight get
LastVarPick 1 add 18 mul sub moveto
VarKeys LastVarPick get show
} if
/updatecanvas VarPic send
LastVarPick null ne
{
/val
systemdict ClassKeys LastClassPick get cvn get % class
VarKeys LastVarPick get % class variable
get
def
[] TextColor TextPic ShowArray
[
{
(CLASS VARIABLE)
( ") VarKeys LastVarPick get 256 string cvs (")
append append append
val Expand
} errored {
cleartomark
[
(CLASS VARIABLE)
( ") VarKeys LastVarPick get 256 string cvs (")
append append append
(Error in CLASS VARIABLE) ()
$error Expand
} if
] TextColor TextPic ShowArray
} if
end
} def
/VarPick
{
null SetMethodPick
null SetInstPick
10 dict begin
/y exch def
/x exch def
/k VarPic /BufferHeight get y sub 18 div floor cvi def
% (pick is % %\n ) [ k VarKeys] dbgprintf
k dup
end
VarKeys length 1 sub le
{ SetVarPick }
{ pop }
ifelse
} def
/SetupNoClass { % - -> - Set up systemdict to look like a class
% systemdict /NoClass systemdict put
systemdict /NoClass
dictbegin
systemdict
{
dup type /dicttype ne
{ def }
{
dup /ClassName known { pop pop } { def } ifelse
} ifelse
} forall
dictend
put
NoClass /InstanceVars 0 dict put
% systemdict /ClassName (NoClass) put
NoClass /ClassName (NoClass) put
} def
/HandlePick { % procedure -> -
PickProcess null ne { PickProcess killprocess } if
fork userdict begin /PickProcess exch def end
} def
SetupNoClass
DoClasses
PicArray forkitems pop
/map win send
% /win null def
% newprocessgroup
% currentfile closefile
EOF