bvs%carlisle@Sun.COM (Bruce V. Schwartz / Marketing Technical Support) (01/05/89)
This is the new version of the browser that was hidden on the SUG SEX
machine in a miscellaneous/unorganized directory. So you may not have seen
this even if you got SEX at SUG.
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, process control (new request cancels
previous), better error handling, faster sorting, and looks better on
B/W screen.
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.
Bruce V. Schwartz
Sun Microsystems
bvs@sun.com
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create:
# browse
# This archive created: Wed Jan 4 18:30:30 1989
export PATH; PATH=/bin:/usr/bin:$PATH
if test -f 'browse'
then
echo shar: "will not over-write existing file 'browse'"
else
cat << \SHAR_EOF > 'browse'
#!/usr/NeWS/bin/psh
%% $Header: pw.ps,v 1.5 88/07/13 15:17:15 bvs Exp $
%
% 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, modify or distribute this file at will.
%
% 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
%
% Copyright (c) 1988 by Sun Microsystems, Inc.
% 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
%
/XNeWS? where { pop } { systemdict /XNeWS? false put } ifelse
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
} 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
classend
def
/PicScrollbar SimpleScrollbar
dictbegin
/Owner null def
/MouseInItem? false def
/ScrollMonitor null def
/ScrollProcess null def
/ScrollDelay 1 60 div 20 div def % 1/10 second
/LastX null def
/LastY null def
dictend
classbegin
/ItemShadeColor .5 def
/new {
/new super send
begin
/ScrollMonitor createmonitor def
currentdict
end
} def
/setowner {
/Owner exch def
} def
/ClientDown { % - => -
CurrentEvent begin XLocation YLocation end
/LastY exch def
/LastX exch def
SetScrollMotion
/MouseInItem? true def
HiliteItem
DoScroll
ScrollProcess null ne
{ ScrollMonitor { ScrollProcess killprocess } monitor }
if
/ScrollProcess { InteractiveScroll } fork pause def
} def
/InteractiveScroll {
{
ScrollDelay sleep
ScrollMonitor { EventInItem? { DoScroll } if } monitor
} loop
} def
/ClientUp { % - => -
% (Clientup\n) [] dbgprintf
% ScrollMonitor { ScrollProcess killprocess } monitor
/ScrollProcess null def
/MouseInItem? false def
UnhiliteItem
ItemValue ItemInitialValue ne { /Notify Owner send } if
} def
/ClientDrag { % - => -
CurrentEvent begin XLocation YLocation end
/LastY exch def
/LastX exch def
CheckItem
} 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
/EventInItem? { % - => bool
ScrollMotion
{
/ScrollAbsolute { false }
/ScrollPageForward % top
{
LastX dup 0 ge exch ButtonSize le
LastY ItemValue ValueToY ButtonSize add ge
LastY ItemHeight ButtonSize sub le
and and and
}
/ScrollPageBackward % bottom
{
LastX dup 0 ge exch ButtonSize le
LastY ButtonSize ge
LastY ItemValue ValueToY le
and and and
}
/ScrollLineForward % top
{
LastX 0 ge
LastX ButtonSize le
LastY ItemHeight ButtonSize sub ge
LastY ItemHeight le
and and and
}
/ScrollLineBackward % bottom
{
LastX 0 ge
LastX ButtonSize le
LastY 0 ge
LastY ButtonSize le
and and and
}
} case
BarViewPercent 1 le { pop false } if
} def
/CheckItem {
ScrollMotion
{
/ScrollAbsolute {DoScroll}
/ScrollPageForward % top
{
/MouseInItem? EventInItem? def
}
/ScrollPageBackward % bottom
{
/MouseInItem? EventInItem? def
}
/ScrollLineForward % top
{
EventInItem? dup
{ MouseInItem? not { HiliteItem } if }
{ MouseInItem? { UnhiliteItem } if }
ifelse
/MouseInItem? exch def
}
/ScrollLineBackward % bottom
{
EventInItem? dup
{ MouseInItem? not { HiliteItem } if }
{ MouseInItem? { UnhiliteItem } if }
ifelse
/MouseInItem? exch def
}
} case
} 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
} 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? not
{
BufferWidth BufferHeight
% 2 copy (scale by % %\n) [ 4 2 roll ] dbgprintf
scale
} if
% (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 true 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
/ReshapeScrollbars {
/HScrollWidth HScrollbar? { ScrollWidth } { 0 } ifelse def
/VScrollWidth VScrollbar? { ScrollWidth } { 0 } ifelse def
10 dict begin
/h ItemHeight def /w ItemWidth def
/s ScrollWidth def
[1 0 .01 .1 BufferWidth ItemWidth VScrollWidth sub div ]
/setrange HScrollbar send
[1 0 .01 .1 BufferHeight ItemHeight HScrollWidth sub div ]
/setrange VScrollbar send
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
%% $Header: browseclass.ps,v 1.4 88/07/13 15:17:06 bvs Exp $
%
% 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, modify or distribute this file at will.
%
% 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
%
% Copyright (c) 1988 by Sun Microsystems, Inc.
%
% 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
%
%
% If you don't use the "browse" script, you will have to alter the
% following line to reflect the location of the file "pw.ps" on your
% system.
%
/PicWindow where
{ pop }
{ systemdict begin (NeWS/pw.ps) LoadFile pop end }
ifelse
/Font15 /Times-Roman findfont 15 scalefont def
/PickProcess null def
/PicArray [ ] def
/win framebuffer /new PicWindow send def
{
/FrameLabel (NeWS Class Browser) 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
0 /setvalue InstPic /VScrollbar get send
0 /setvalue MethodPic /VScrollbar get send
0 /setvalue VarPic /VScrollbar get send
0 /setvalue TextPic /VScrollbar get send
/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
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
20 dict dup begin
/arraytype
{ dup xcheck
{ StartXArray { dup type exec } forall EndXArray }
{ StartArray { dup type exec } forall EndArray }
ifelse } def
/dicttype
{
/tmp exch def
StartLine (<<Dictionary Begin>>) AddString StartLine
tmp {
/tmp exch def dup type exec
( ) AddString
/tmp load dup type dup /dicttype eq
{ pop pop (***Dictionary***) AddString } % no recursion here!
{ exec }
ifelse
StartLine
} forall
StartLine (<<Dictionary END>>) AddString StartLine
} 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
/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
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 /arraytype eq
/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 { /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 /InstanceVarDict 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 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
} if
lastpick k ne
{
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
/InstanceVarDict 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 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 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 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
NoClass /InstanceVarDict 0 dict put
systemdict /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
SHAR_EOF
chmod +x 'browse'
fi
exit 0
# End of shell archive