"
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
StandardSystemView subclass:#Launcher
instanceVariableNames:'myMenu logoLabel'
classVariableNames:''
poolDictionaries:''
category:'Interface-Smalltalk'
!
Launcher comment:'
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.15 1994-08-24 04:03:06 claus Exp $
'!
!Launcher class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
version
"
$Header: /cvs/stx/stx/libtool/OldLauncher.st,v 1.15 1994-08-24 04:03:06 claus Exp $
"
!
documentation
"
Launcher allows startup of smalltalk applications
"
! !
!Launcher class methodsFor:'instance creation'!
new
^ super
extent:(100 @ 100)
label:'smallTalk'
icon:(Form fromFile:'SmalltalkX.xbm' resolution:100)
"Launcher start"
! !
!Launcher methodsFor:'initialize / release'!
initialize
super initialize.
self initializeMenu.
self initializeLogo.
"/ myMenu borderWidth:0.
myMenu origin:(0.0 @ logoLabel height).
"/ myMenu font:(self font).
"/ self extent:(myMenu extent).
!
initializeLogo
logoLabel := Label in:self.
logoLabel form:(Image fromFile:'bitmaps/SmalltalkX.xbm').
logoLabel origin:0.0 @ 0.0.
logoLabel borderWidth:0.
!
initializeMenu
myMenu := ClickMenuView
labels:(resources array:#(
'Browsers'
'Workspace'
'File Browser'
'Projects'
'-'
'Utilities'
'Goodies'
'Games & Demos'
'-'
'info & help'
'-'
'snapshot'
'-'
'exit'
))
selectors:#(browserMenu
startWorkspace
startFileBrowser
projectMenu
nil
utilityMenu
goodyMenu
gamesMenu
nil
helpMenu
nil
saveImage
nil
exitSmalltalk
)
receiver:self
in:self.
myMenu subMenuAt:#browserMenu put:(
PopUpMenu labels:(resources array:#(
'System Browser'
'Class Hierarchy Browser'
'Implementors'
'Senders'
'-'
'Changes Browser'
'-'
'Directory Browser'
))
selectors:#(
startSystemBrowser
startHierarchyBrowser
startImplementorsBrowser
startSendersBrowser
nil
startChangesBrowser
nil
startDirectoryBrowser
)
receiver:self
for:self
).
myMenu subMenuAt:#utilityMenu put:(
PopUpMenu labels:(resources array:#(
'Transcript'
'-'
'Window tree'
'View inspect'
'View destroy'
'Class tree'
'-'
'Event monitor'
'Process monitor'
'Memory monitor'
'Memory usage'
'-'
'collect Garbage'
'collect Garbage & compress'
'-'
'full screen hardcopy'
'screen area hardcopy'
'view hardcopy'
'-'
'ScreenSaver'
))
selectors:#(
startTranscript
nil
startWindowTreeView
viewInspector
viewKiller
startClassTreeView
nil
startEventMonitor
startProcessMonitor
startMemoryMonitor
startMemoryUsage
nil
garbageCollect
compressingGarbageCollect
nil
fullScreenHardcopy
screenHardcopy
viewHardcopy
nil
screenSaverMenu
)
receiver:self
for:self
).
(myMenu subMenuAt:#utilityMenu) subMenuAt:#screenSaverMenu put:(
PopUpMenu labels:(resources array:#(
'simple'
'spotlight'
'moving spotlight'
))
selectors:#(
startScreenSaver1
startScreenSaver2
startScreenSaver3
)
receiver:self
for:self
).
(Display isKindOf:GLXWorkstation) ifTrue:[
myMenu subMenuAt:#gamesMenu put:(
PopUpMenu labels:(resources array:#(
'Tetris'
'TicTacToe'
'-'
'Animation'
'Globe'
'-'
'GL 3D demos'
'-'
'LogicTool'
))
selectors:#(
startTetris
startTicTacToe
nil
startAnimation
startGlobeDemo
nil
glDemos
nil
startLogicTool
)
receiver:self
for:self
).
(myMenu subMenuAt:#gamesMenu) subMenuAt:#glDemos put:(
PopUpMenu labels:(resources array:#(
'plane'
'tetra'
'cube (wireframe)'
'cube (solid)'
'cube (light)'
'sphere (wireframe)'
'sphere (light)'
'planet'
'teapot'
'logo'
))
selectors:#(
startGLPlaneDemo
startGLTetraDemo
startGLWireCubeDemo
startGLCubeDemo
startGLCubeDemo2
startGLWireSphereDemo
startGLSphereDemo
startGLPlanetDemo
startGLTeapotDemo
startGLLogoDemo1
)
receiver:self
for:self
).
] ifFalse:[
myMenu subMenuAt:#gamesMenu put:(
PopUpMenu labels:(resources array:#(
'Tetris'
'TicTacToe'
'-'
'Animation'
'Globe'
'-'
'LogicTool'
))
selectors:#(
startTetris
startTicTacToe
nil
startAnimation
startGlobeDemo
nil
startLogicTool
)
receiver:self
for:self
)
].
Project notNil ifTrue:[
myMenu subMenuAt:#projectMenu put:(
PopUpMenu labels:(resources array:#(
'new project'
'-'
'select project'
))
selectors:#(
newProject
nil
selectProject
)
receiver:self
for:self
).
].
myMenu subMenuAt:#goodyMenu put:(
PopUpMenu labels:(resources array:#(
'Clock'
'Round Clock'
"
'Address Book'
"
'-'
'Directory View'
'MailTool'
'NewsTool'
'-'
'DrawTool'
))
selectors:#(
startClock
startRoundClock
"
startAddressBook
"
nil
startDirectoryView
startMailTool
startNewsTool
nil
startDrawTool
)
receiver:self
for:self
).
myMenu subMenuAt:#helpMenu put:(
PopUpMenu labels:(resources array:#(
'About'
'-'
'Overview'
'Getting started'
'Customizing'
'Tools'
'programming'
'other topics'
'-'
"
'Help Browser'
"
'Manual Browser'
))
selectors:#(
showAbout
nil
showOverview
showGettingStarted
showCustomizing
tools
programming
otherTopics
nil
"
startHelpView
"
startManualBrowser
)
receiver:self
for:self
).
(myMenu subMenuAt:#helpMenu) subMenuAt:#tools put:(
PopUpMenu labels:(resources array:#(
'System Browser'
'File Browser'
'Changes Browser'
'Debugger'
'Inspector'
))
selectors:#(
showSystemBrowserDocumentation
showFileBrowserDocumentation
showChangesBrowserDocumentation
showDebuggerDocumentation
showInspectorDocumentation
)
receiver:self
for:self
).
(myMenu subMenuAt:#helpMenu) subMenuAt:#otherTopics put:(
PopUpMenu labels:(resources array:#(
'ST/X history'
'Garbage collection'
'Language & primitives'
'Error messages'
'-'
'stc manual page'
'smalltalk manual page'
))
selectors:#(
showHistoryDocumentation
showGCDocumentation
showLanguageDocumentation
showErrorMessageDocumentation
nil
showSTCManualPage
showSmalltalkManualPage
)
receiver:self
for:self
).
(myMenu subMenuAt:#helpMenu) subMenuAt:#programming put:(
PopUpMenu labels:(resources array:#(
'useful selectors'
'views - quick intro'
'breakpoints & tracing'
'processes'
'timers & delays'
'exceptions & signals'
'GL 3D graphics'
))
selectors:#(
showUsefulSelectors
showQuickViewIntro
showDebuggingInfo
showProcessInfo
showTimerInfo
showExceptionInfo
showGLDocumentation
)
receiver:self
for:self
).
!
realize
|myExtent|
myExtent := (myMenu extent + (0 @ (logoLabel height))).
self extent:myExtent.
self minExtent:myExtent.
self maxExtent:myExtent.
super realize.
"
catch errors - dont want a debugger here ...
"
Processor activeProcess emergencySignalHandler:[:ex |
|box|
box := YesNoBox title:('Error while launching ...\' , ex errorString , '\\debug ?') withCRs.
"
icon should be whatever WarnBoxes use as icon
"
box formLabel form:(WarningBox new formLabel label).
box yesAction:[Debugger
enter:ex suspendedContext
withMessage:ex errorString].
box showAtPointer.
Object abortSignal raise.
].
!
reinitialize
"sent after snapin - first reinit menuview,
then adjust my size"
super reinitialize.
myMenu reinitialize.
self extent:(myMenu extent).
!
destroy
"re-confirm when clisng Launcher - since if you closed
the last launcher, you might loose the possibility to
communicate with the system ..."
(self confirm:(resources string:'close Launcher ?')) ifTrue:[
super destroy
]
!
addToCurrentProject
"ignored here - the launcher is always global."
^ self
! !
!Launcher methodsFor:'accessing'!
menu
^ myMenu
! !
!Launcher methodsFor:'private'!
showDocumentFile:name
|s f isRTF|
isRTF := true.
s := Smalltalk systemFileStreamFor:name , '.rtf'.
s isNil ifTrue:[
isRTF := false.
s := Smalltalk systemFileStreamFor:name , '.doc'.
s isNil ifTrue:[
self warn:('document ' , name , ' (.rtf/.doc) not available.\\check your installation.' withCRs).
^ nil
].
].
f := s pathName.
isRTF ifTrue:[
DocumentView openOn:f.
^ self
].
(Workspace openOn:f) readOnly
!
saveScreenImage:anImage
"save an image into a file
- ask user for filename using a fileSelectionBox."
|box|
box := FileSelectionBox
title:'save image in:'
okText:'save'
abortText:'cancel'
action:[:fileName | anImage saveOn:fileName].
box pattern:'*.tiff'.
box showAtPointer
!
closeDownViews
"tell each topview that we are going to terminate and give it chance
to save its contents."
ObjectMemory changed:#aboutToExit
! !
!Launcher methodsFor:'events'!
saveAndTerminate
ObjectMemory snapShotOn:name
! !
!Launcher methodsFor:'menu actions'!
startSystemBrowser
SystemBrowser open
!
startHierarchyBrowser
|enterBox|
enterBox := EnterBox new.
enterBox title:(resources at:'name of class:') withCRs.
" enterBox abortText:(resources at:'abort')." "this is the default anyway"
enterBox okText:(resources at:'browse').
enterBox action:[:className |
|class|
class := Smalltalk at:className asSymbol ifAbsent:[nil].
class isBehavior ifFalse:[
self warn:(resources at:'no such class')
] ifTrue:[
SystemBrowser browseClassHierarchy:class
]
].
enterBox showAtPointer
!
startImplementorsBrowser
|enterBox|
enterBox := EnterBox new.
enterBox title:(resources at:'selector:') withCRs.
" enterBox abortText:(resources at:'abort')." "this is the default anyway"
enterBox okText:(resources at:'browse').
enterBox action:[:selectorName |
SystemBrowser browseImplementorsOf:selectorName
].
enterBox showAtPointer
!
startSendersBrowser
|enterBox|
enterBox := EnterBox new.
enterBox title:(resources at:'selector:') withCRs.
" enterBox abortText:(resources at:'abort')." "this is the default anyway"
enterBox okText:(resources at:'browse').
enterBox action:[:selectorName |
SystemBrowser browseAllCallsOn:selectorName
].
enterBox showAtPointer
!
startChangesBrowser
ChangesBrowser open
!
startFileBrowser
FileBrowser open
!
startDirectoryBrowser
DirectoryBrowser open
!
startDirectoryView
DirectoryView open
!
startWorkspace
Workspace open
!
saveImage
|saveBox|
saveBox := EnterBox new.
saveBox title:(resources at:'filename for image:') withCRs.
" saveBox abortText:(resources at:'abort')." "this is the default anyway ..."
saveBox okText:(resources at:'save').
"this is a kludge - put into above if-block once
stack contexts survive a snapout/snapin
(I think, it could be done now ...)
"
saveBox action:[:fileName |
ObjectMemory snapShotOn:fileName.
].
saveBox initialText:(ObjectMemory nameForSnapshot).
saveBox showAtPointer
!
exitSmalltalk
|exitBox|
exitBox := EnterBox2 new.
exitBox title:(resources at:'save state before exiting ?\\filename for image:') withCRs.
" exitBox abortText:(resources at:'abort')." "this is the default anyway ..."
exitBox okText:(resources at:'exit').
exitBox okText2:(resources at:'save & exit').
exitBox action:[:dummyName |
self closeDownViews.
Smalltalk exit
].
exitBox action2:[:fileName |
ObjectMemory snapShotOn:fileName.
"this is NOT required - all data should be in the snapshot ...
... however, if remote disks/mounatble filesystems are involved,
which may not be present the next time, it may make sense to
uncomment it and query for saving - time will show which is better.
"
"
self closeDownViews.
"
Smalltalk exit
].
exitBox initialText:(ObjectMemory nameForSnapshot).
exitBox showAtPointer
! !
!Launcher methodsFor:'utility menu actions'!
viewHardcopy
Processor addTimedBlock:[
|v|
v := Display viewFromUser.
v notNil ifTrue:[
self saveScreenImage:(Image fromView:(v topView))
]
] afterSeconds:1
!
fullScreenHardcopy
Processor addTimedBlock:[
self saveScreenImage:(Image fromScreen)
] afterSeconds:1
!
screenHardcopy
|area|
Processor addTimedBlock:[
area := Rectangle fromUser.
(area width > 0 and:[area height > 0]) ifTrue:[
self saveScreenImage:(Image fromScreen:area)
]
] afterSeconds:1
!
viewKiller
|v|
(Delay forSeconds:1) wait.
v := Display viewFromUser.
v isNil ifTrue:[
self warn:'sorry, this is not a smalltalk view'
] ifFalse:[
v topView destroy
]
!
viewInspector
|v|
(Delay forSeconds:1) wait.
v := Display viewFromUser.
v isNil ifTrue:[
self warn:'sorry, this is not a smalltalk view'
] ifFalse:[
v topView inspect
]
!
startWindowTreeView
WindowTreeView open
!
startClassTreeView
ClassTreeGraphView open
!
startEventMonitor
EventMonitor open
!
startProcessMonitor
ProcessMonitor open
!
startMemoryMonitor
MemoryMonitor open
!
startMemoryUsage
MemoryUsageView open
!
startTranscript
((Smalltalk at:#Transcript) isKindOf:TextCollector) ifTrue:[
"there is only one transcript"
Transcript topView isCollapsed ifTrue:[
"it is iconified"
Transcript topView unrealize.
Transcript topView realize.
].
Transcript topView raise
] ifFalse:[
Smalltalk at:#Transcript put:(TextCollector newTranscript)
]
!
startScreenSaver1
ScreenSaver open
!
startScreenSaver2
LightInTheDark open
!
startScreenSaver3
LightInTheDark2 open
!
garbageCollect
ObjectMemory markAndSweep
!
compressingGarbageCollect
|nBytesBefore nReclaimed|
nBytesBefore := ObjectMemory oldSpaceUsed.
ObjectMemory garbageCollect.
nReclaimed := nBytesBefore - ObjectMemory oldSpaceUsed.
nReclaimed > 0 ifTrue:[
Transcript show:'reclaimed '.
nReclaimed > 1024 ifTrue:[
nReclaimed > (1024 * 1024) ifTrue:[
Transcript show:(nReclaimed // (1024 * 1024)) printString.
Transcript showCr:' Mb.'
] ifFalse:[
Transcript show:(nReclaimed // 1024) printString.
Transcript showCr:' Kb.'
]
] ifFalse:[
Transcript show:nReclaimed printString.
Transcript showCr:' bytes.'
]
]
! !
!Launcher methodsFor:'project menu actions'!
projectMenu
"this is sent, if ST/X has been built without Projects/ChangeSets."
self warn:'The system has been built without support for Project'.
!
newProject
(ProjectView for:(Project new)) open
!
selectProject
|list box|
list := Project allInstances.
box := ListSelectionBox new.
box list:(list collect:[:p | p name]).
box title:(resources string:'select a project').
box action:[:selection |
|project|
project := list detect:[:p | p name = selection] ifNone:[nil].
project isNil ifTrue:[
Transcript showCr:'no such project'
] ifFalse:[
project showViews.
Project current:project
]
].
box showAtPointer
! !
!Launcher methodsFor:'goody menu actions'!
startXterm
OperatingSystem executeCommand:'xterm &'
!
startAddressBook
AddressBook open
!
startNewsTool
NewsView open
!
startMailTool
MailView open
!
startClock
Clock open
!
startRoundClock
RoundClock2 open
! !
!Launcher methodsFor:'demo menu actions'!
startAnimation
Animation open
!
startGlobeDemo
GlobeDemo open
!
startRoundGlobeDemo
RoundGlobeDemo open
!
startGLSphereDemo
GLSphereDemoView2 open
!
startGLTeapotDemo
GLTeapotDemo open
!
startGLPlaneDemo
GLPlaneDemoView2 open
!
startGLWireCubeDemo
GLWireCubeDemoView open
!
startGLWireSphereDemo
GLWireSphereDemoView open
!
startGLPlanetDemo
GLPlanetDemoView open
!
startGLCubeDemo
GLCubeDemoView open
!
startGLCubeDemo2
GLCubeDemoView2 open
!
startGLTetraDemo
GLTetraDemoView open
!
startGLLogoDemo1
Logo3DView1 open
!
startTetris
Tetris open
!
startTicTacToe
TicTacToe open
!
startDrawTool
DrawTool open
!
startLogicTool
LogicTool open
! !
!Launcher methodsFor:'doc menu actions'!
warnIfAbsent:aPath
|s|
s := Smalltalk systemFileStreamFor:aPath.
s isNil ifTrue:[
self warn:('document ' , aPath , ' not available').
^ nil
].
^ s pathName
!
showAbout
|box dark green|
device hasColors ifTrue:[
green := (Color red:0 green:80 blue:20) darkened.
] ifFalse:[
green := White.
].
device hasGreyscales ifTrue:[
dark := Color grey:10.
] ifFalse:[
dark := Black.
].
box := InfoBox new.
box viewBackground:dark.
box form:(Form
fromFile:'SmalltalkX.xbm'
resolution:100).
box formLabel viewBackground:dark.
box formLabel foregroundColor:green backgroundColor:dark.
box textLabel viewBackground:dark.
box textLabel foregroundColor:White backgroundColor:dark.
box title:
'Smalltalk/X
Version ......... ' , Smalltalk versionString , ' (' , Smalltalk versionDate printString , ')
Configuration ... ' , Smalltalk configuration , '
Running on ...... ' , OperatingSystem getHostName , '
' , Smalltalk copyrightString.
box okText:'close'.
box autoHideAfter:10 with:[].
box showAt:device center - (box extent // 2).
!
showOverview
self showDocumentFile:'doc/overview'
!
showCustomizing
self showDocumentFile:'doc/manuals/customizing'
!
showGettingStarted
self showDocumentFile:'doc/manuals/gettingStarted'
!
showSystemBrowserDocumentation
self showDocumentFile:'doc/misc/sbrowser'
!
showFileBrowserDocumentation
self showDocumentFile:'doc/misc/fbrowser'
!
showChangesBrowserDocumentation
self showDocumentFile:'doc/misc/cbrowser'
!
showDebuggerDocumentation
self showDocumentFile:'doc/misc/debugger'
!
showInspectorDocumentation
self showDocumentFile:'doc/misc/inspector'
!
showHistoryDocumentation
self showDocumentFile:'doc/misc/history'
!
showGCDocumentation
self showDocumentFile:'doc/misc/GC'
!
showGLDocumentation
self showDocumentFile:'doc/misc/GL'
!
showLanguageDocumentation
self showDocumentFile:'doc/misc/language'
!
showErrorMessageDocumentation
self showDocumentFile:'doc/misc/errormsg'
!
showSTCManualPage
self showDocumentFile:'doc/misc/stc'
!
showSmalltalkManualPage
self showDocumentFile:'doc/misc/smalltalk'
!
showUsefulSelectors
self showDocumentFile:'doc/misc/beginner'
!
showQuickViewIntro
self showDocumentFile:'doc/misc/quick_view_intro'
!
showDebuggingInfo
self showDocumentFile:'doc/misc/debugging'
!
showProcessInfo
self showDocumentFile:'doc/misc/processes'
!
showExceptionInfo
self showDocumentFile:'doc/misc/exceptions'
!
showTimerInfo
self showDocumentFile:'doc/misc/timing'
!
startHelpView
self warn:'The HelpSystem is still under construction.
You will see a pre-pre release.'.
HelpView start
!
startManualBrowser
ManualBrowser isLoaded ifFalse:[
ManualBrowser autoload.
"
did it load ?
"
ManualBrowser isLoaded ifFalse:[
self warn:'The ManualBrowser is a Tomcat add-on; not included in this package.'.
^self
]
].
self warn:'The HelpSystem is still under construction.
You will see a pre release.'.
ManualBrowser new
! !