bice@hbo.UUCP (Brent A. Bice) (06/27/90)
Oooops. Forgot to include the class browser for skdutta at the end of my last
post... Here it is.
#!/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