"
COPYRIGHT (c) 1995 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.
"
ApplicationModel subclass:#NewLauncher
instanceVariableNames:'myMenu buttonPanel transcript infoView infoProcess helpIsOn'
classVariableNames:'CachedAboutIcon'
poolDictionaries:''
category:'Interface-Smalltalk'
!
!NewLauncher class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1995 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.
"
!
customization
"
Of course, it is possible to change the NewLauncher class itself
as appropriate, however, we suggest you create a subclass (say MyLauncher),
define it as autoloaded in the patches file, and redefined some methods
there. That way, your changes are easier to reintroduce in case of
an ST/X upgrade.
adding more buttons to the button-panel:
see the method #buttonPanelSpec;
it defines a list of selectors and icons, which is used by
#setupButtonPanelIn:.
There, for each entry, a button with that icon is created,
which sends a selector-message to the launcher.
Add entries to that list, and define appropriate methods.
For example, to add a button which opens a drawTool,
change #buttonPanelSpec to:
buttonPanelSpec
^ #(
#(startSystemBrowser 'SBrowser32x32.xbm')
#(startFileBrowser 'FBrowser32x32.xbm')
#(nil nil)
#(startChangesBrowser 'CBrowser32x32.xbm')
#(nil nil)
#(nil nil)
#(startDrawTool 'DrawTool.xbm')
)
the panel adjusts its height as appropriate - you may want to
create new (small) icons for a good look.
adding an entry to a menu:
see the #setupMenu method; either add another top-menu, or
add entries to an existing menu.
"
!
documentation
"
a new launcher, combining old Launchers menu and transcript into
one view. (you no longer have to move two views around all the time ...).
Also, this app makes first use of the new compatibility framework;
you will notice, that this is a subclass of ApplicationModel.
New applications will no longer be built as subclasses of standardSystemView.
"
! !
!NewLauncher class methodsFor:'defaults'!
aboutIcon
|image|
CachedAboutIcon notNil ifTrue:[^ CachedAboutIcon].
image := Image fromFile:'SmalltalkX.xbm'.
image notNil ifTrue:[
|green dark|
Display hasColors ifTrue:[
green := (Color red:0 green:80 blue:20) "darkened".
dark := Color grey:10.
image photometric:#palette.
] ifFalse:[
dark := Color black.
green := Color white.
image photometric:#blackIs0.
].
image colorMap:(Array with:dark with:green).
"/ Display depth > 2 ifTrue:[
"/ image := (Image implementorForDepth:Display depth) fromImage:image.
"/ ]
].
CachedAboutIcon := image.
^ image
"
CachedAboutIcon := nil.
NewLauncher aboutIcon
"
"Modified: 20.10.1995 / 21:54:58 / cg"
!
smallAboutIcon
|image|
image := self aboutIcon.
image notNil ifTrue:[
image := image magnifiedBy:0.4.
].
^ image
"
CachedAboutIcon := nil.
NewLauncher aboutIcon.
NewLauncher smallAboutIcon.
"
! !
!NewLauncher methodsFor:'actions - about & help'!
about
|box|
box := AboutBox new.
box autoHideAfter:10 with:[].
box showAtCenter
!
showDocumentation:aRelativeDocFilePath
"
although that one is not yet finished,
its better than nothing ...
"
XtHTML notNil ifTrue:[
"
temporary kludge;
not all machines can autoload binaries;
however, on my SGI (which can) we want it
to load automatically.
"
XtHTML isLoaded ifFalse:[
(OperatingSystem getSystemType = 'iris') ifTrue:[
ErrorSignal catch:[XtHTML autoload]
]
].
XtHTML isLoaded ifTrue:[
XtHTML openFullOnDocumentationFile:aRelativeDocFilePath.
^ self
].
].
self warn:'Sorry, the ST/X HTML reader is not (yet)
included in this architectures release.
Please use Mosaic, netscape, chimera or any
other HTML viewer to see the documentation.
The documentation is found in the ''doc/online'' directory.'.
"Modified: 31.8.1995 / 13:11:08 / claus"
!
startDocumentationTool
self showDocumentation:'TOP.html'
"Modified: 31.8.1995 / 13:11:28 / claus"
!
toggleActiveHelp:aBoolean
ActiveHelp notNil ifTrue:[
helpIsOn := aBoolean.
helpIsOn ifTrue:[
ActiveHelp start
] ifFalse:[
ActiveHelp stop
]
].
! !
!NewLauncher methodsFor:'actions - classes'!
browseImplementors
|enterBox|
enterBox := EnterBox title:(resources at:'Browse implementors of:') withCRs.
enterBox okText:(resources at:'browse').
enterBox action:[:selectorName |
|cls|
self withWaitCursorDo:[SystemBrowser browseImplementorsOf:selectorName]
].
enterBox showAtPointer
!
browseSenders
|enterBox|
enterBox := EnterBox title:(resources at:'Browse senders of:') withCRs.
enterBox okText:(resources at:'browse').
enterBox action:[:selectorName |
|cls|
self withWaitCursorDo:[SystemBrowser browseAllCallsOn:selectorName]
].
enterBox showAtPointer
!
startChangesBrowser
self withWaitCursorDo:[ChangesBrowser open]
!
startClassBrowser
SystemBrowser askThenBrowseClass
!
startClassHierarchyBrowser
SystemBrowser askThenBrowseClassHierarchy
!
startClassTreeView
self withWaitCursorDo:[ClassTreeGraphView open]
!
startFileBrowser
self withWaitCursorDo:[FileBrowser open]
!
startFullClassBrowser
SystemBrowser askThenBrowseFullClassProtocol
!
startSystemBrowser
self withWaitCursorDo:[SystemBrowser open]
!
startWorkspace
Workspace open
! !
!NewLauncher methodsFor:'actions - demos'!
openDemo:className
(Smalltalk at:className) open
!
startTetris
Tetris open
!
startTicTacToe
TicTacToeGame open
!
startTicTacToe2
TicTacToeGame open2UserGame
! !
!NewLauncher methodsFor:'actions - file'!
exit
(self confirm:(resources string:'Are you certain you want to exit without saving ?'))
ifTrue:[
self saveAllViews.
Smalltalk exit
]
!
objectModuleDialog
|allModules moduleNames
allObjects methodObjects methodNames
box l unloadButton
list1 list2 listView1 listView2
y panel showBuiltIn showModules showMethods moduleListUpdater check|
showBuiltIn := true asValue.
showModules := ObjectFileLoader notNil asValue.
showMethods := ObjectFileLoader notNil asValue.
moduleListUpdater := Plug new.
moduleListUpdater
respondTo:#getModules
with:[
|l|
l := Array new.
(showModules value or:[showBuiltIn value]) ifTrue:[
allModules := ObjectMemory binaryModuleInfo asOrderedCollection.
(showBuiltIn value and:[showModules value]) ifFalse:[
allModules := allModules select:[:i |
|wantToSee|
wantToSee := (i at:#dynamic).
showBuiltIn value ifTrue:[
wantToSee := wantToSee not
].
wantToSee
]
].
"/ sorting by reverse id brings newest ones to the top (a side effect)
allModules sort:[:a :b | (a at:#id) > (b at:#id)].
moduleNames := allModules collect:[:entry | (entry at:#name)].
l := l , moduleNames.
].
showMethods value ifTrue:[
allObjects := ObjectFileLoader loadedObjectHandles.
methodObjects := (allObjects select:[:h | h isMethodHandle]) asArray.
methodNames := methodObjects collect:[:mH | mH method isNil ifTrue:[
'compiled method - removed'
] ifFalse:[
'compiled method ' , mH method whoString
].
].
l := l , methodNames.
].
list1 list:l.
unloadButton disable.
].
list1 := SelectionInList new.
list2 := SelectionInList new.
showBuiltIn onChangeSend:#getModules to:moduleListUpdater.
showModules onChangeSend:#getModules to:moduleListUpdater.
showMethods onChangeSend:#getModules to:moduleListUpdater.
box := Dialog new.
box label:(resources string:'Module dialog').
listView1 := HVScrollableView for:SelectionInListView miniScrollerH:true.
listView1 model:list1.
listView1 origin:0.0@0.0 corner:1.0@0.4. "/ ; inset:2.
listView1 action:[:sel |
|info classNames tabs|
(showModules value or:[showBuiltIn value]) ifTrue:[
info := allModules at:sel ifAbsent:nil.
].
info isNil ifTrue:[
"/ selected a method
list2 list:#().
unloadButton enable.
] ifFalse:[
"/ selected a package
tabs := TabulatorSpecification unit:#inch positions:#(0 3).
"/ fill bottom list with class-info
classNames := (info at:#classNames) asSortedCollection.
classNames := classNames collect:[:cName |
|cls entry rev listEntry|
listEntry := MultiColListEntry new:2 tabulatorSpecification:tabs.
listEntry colAt:1 put:cName.
cls := Smalltalk classNamed:cName.
cls isNil ifTrue:[
listEntry colAt:2 put:'(class removed)'.
] ifFalse:[
rev := cls revision.
rev notNil ifTrue:[
listEntry colAt:2 put:'(rev' , rev , ')'
].
].
listEntry
].
list2 list:classNames.
(info at:#dynamic) ifTrue:[
unloadButton enable.
] ifFalse:[
unloadButton disable.
].
]
].
panel := HorizontalPanelView new.
panel add:(l := Label label:'Objects:').
l adjust:#left; borderWidth:0.
panel add:(CheckBox label:'builtin' model:showBuiltIn).
panel add:(check := CheckBox label:'modules' model:showModules).
ObjectFileLoader isNil ifTrue:[check disable].
panel add:(check := CheckBox label:'methods' model:showMethods).
ObjectFileLoader isNil ifTrue:[check disable].
panel horizontalLayout:#fitSpace.
box addComponent:panel tabable:true.
box addComponent:listView1 tabable:true.
listView1 topInset:(View viewSpacing + panel preferredExtent y).
listView1 origin:0.0@0.0 corner:1.0@0.4. "/ ; inset:2.
l := box addTextLabel:(resources string:'contained classes/subsets:').
l adjust:#left; borderWidth:0.
l origin:0.0@0.4 corner:1.0@0.4.
l topInset:(View viewSpacing).
l bottomInset:((l preferredExtent y) negated - View viewSpacing).
listView2 := HVScrollableView for:SelectionInListView miniScrollerH:true.
listView2 model:list2; printItems:false.
box addComponent:listView2 tabable:true.
listView2 origin:0.0@0.4 corner:1.0@1.0. "/ ; inset:2.
listView2 disable.
unloadButton := Button label:(resources string:'unload').
unloadButton action:[
self withWaitCursorDo:[
box withWaitCursorDo:[
|info idx pathName|
idx := list1 selectionIndex.
info := allModules at:idx ifAbsent:nil.
info isNil ifTrue:[
"/ selected a method
idx := idx - allModules size.
pathName := (methodObjects at:idx) pathName.
] ifFalse:[
"/ selected a package
pathName := (info at:#pathName).
].
ObjectFileLoader unloadObjectFile:pathName.
moduleListUpdater getModules.
unloadButton disable.
]
]
].
moduleListUpdater getModules.
box addButton:unloadButton.
box addAbortButtonLabelled:(resources string:'close').
y := box yPosition.
listView2 topInset:(l preferredExtent y + 5).
listView2 bottomInset:(box preferredExtent y - y).
box width:(350 min:(box device width * 2 // 3));
height:(450 min:(box device height - 50));
sizeFixed:true.
box showAtPointer.
"Modified: 17.9.1995 / 16:47:50 / claus"
!
snapshot
|saveBox|
saveBox := EnterBox title:(resources at:'filename for image:') withCRs.
saveBox okText:(resources at:'save').
saveBox action:[:fileName |
(ObjectMemory snapShotOn:fileName) ifFalse:[
"
snapshot failed for some reason (disk full, no permission etc.)
"
self warn:(resources string:'failed to save snapshot image (disk full or not writable)').
]
].
saveBox initialText:(ObjectMemory nameForSnapshot).
saveBox label:'save image'.
saveBox showAtPointer
!
snapshotAndExit
|saveBox|
saveBox := EnterBox title:(resources at:'filename for image:') withCRs.
saveBox okText:(resources at:'save & exit').
saveBox action:[:fileName |
(ObjectMemory snapShotOn:fileName) ifFalse:[
"
snapshot failed for some reason (disk full, no permission etc.)
Do NOT exit in this case.
"
self warn:(resources string:'failed to save snapshot image (disk full or not writable)').
] ifTrue:[
"
saveAllViews tells all views to shutdown neatly
(i.e. offer a chance to save the contents to a file).
This is NOT required - all data should be in the snapshot ...
... however, if remote disks/mountable 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 saveAllViews.
"
Smalltalk exit
]
].
saveBox initialText:(ObjectMemory nameForSnapshot).
saveBox label:'save image & exit'.
saveBox showAtPointer
! !
!NewLauncher methodsFor:'actions - goodies'!
startCalendar
Calendar open
!
startClock
RoundClock open
!
startMailTool
MailView open
!
startNewsTool
NewsView open
! !
!NewLauncher methodsFor:'actions - projects'!
newProject
Project notNil ifTrue:[
(ProjectView for:(Project new)) open
]
!
selectProject
|list box|
Project notNil ifTrue:[
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
]
! !
!NewLauncher methodsFor:'actions - settings'!
compilerSettings
|box warnings warnSTX warnUnderscore warnOldStyle allowUnderscore immutableArrays
warnSTXBox warnUnderscoreBox warnOldStyleBox
stcCompilation compilationList stcCompilationOptions stcIncludes stcDefines stcOptions
stcLibraries historyLines catchRedefs
warnEnabler check y component|
warnings := Compiler warnings asValue.
warnSTX := Compiler warnSTXSpecials asValue.
warnUnderscore := Compiler warnUnderscoreInIdentifier asValue.
warnOldStyle := Compiler warnOldStyleAssignment asValue.
allowUnderscore := Compiler allowUnderscoreInIdentifier asValue.
immutableArrays := Compiler arraysAreImmutable asValue.
stcCompilationOptions := #( always default never).
stcCompilation := SelectionInList new list:(resources array:#('always' 'primitive code only' 'never')).
stcCompilation selectionIndex:2.
stcIncludes := Compiler stcCompilationIncludes asValue.
stcDefines := Compiler stcCompilationDefines asValue.
stcOptions := Compiler stcCompilationOptions asValue.
ObjectFileLoader notNil ifTrue:[
stcLibraries := (String fromStringCollection:ObjectFileLoader searchedLibraries separatedBy:' ') asValue.
].
catchRedefs := Class catchMethodRedefinitions asValue.
historyLines := (HistoryManager notNil and:[HistoryManager isActive]) asValue.
warnEnabler := Plug new.
warnEnabler
respondTo:#check
with:[warnings value ifTrue:[
warnSTXBox enable.
warnOldStyleBox enable.
allowUnderscore value ifTrue:[
warnUnderscoreBox enable.
] ifFalse:[
warnUnderscoreBox disable.
].
] ifFalse:[
warnSTXBox disable.
warnUnderscoreBox disable.
warnOldStyleBox disable.
]].
warnings onChangeSend:#check to:warnEnabler.
allowUnderscore onChangeSend:#check to:warnEnabler.
box := DialogBox new.
box label:(resources string:'Compiler settings').
box addCheckBox:(resources string:'catch method redefinitions') on:catchRedefs.
check := box addCheckBox:(resources string:'keep history line in methods') on:historyLines.
HistoryManager isNil ifTrue:[check disable].
box addHorizontalLine.
ObjectFileLoader notNil ifTrue:[
compilationList := box addPopUpList:(resources string:'compilation to machine code') on:stcCompilation.
stcCompilation selectionIndex:( stcCompilationOptions indexOf:(Compiler stcCompilation) ifAbsent:2).
y := box yPosition.
component := box addTextLabel:(resources string:'stc include directories:').
component width:0.5; adjust:#right; borderWidth:0.
box yPosition:y.
component := box addInputFieldOn:stcIncludes tabable:true.
component width:0.5; left:0.5; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:'stc defines:'.
component width:0.5; adjust:#right; borderWidth:0.
box yPosition:y.
component := box addInputFieldOn:stcDefines tabable:true.
component width:0.5; left:0.5; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:'stc options:'.
component width:0.5; adjust:#right; borderWidth:0.
box yPosition:y.
component := box addInputFieldOn:stcOptions tabable:true.
component width:0.5; left:0.5; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
y := box yPosition.
component := box addTextLabel:'stc C-libraries:'.
component width:0.5; adjust:#right; borderWidth:0.
box yPosition:y.
component := box addInputFieldOn:stcLibraries tabable:true.
component width:0.5; left:0.5; immediateAccept:true; acceptOnLeave:false; cursorMovementWhenUpdating:#beginOfLine.
box addVerticalSpace.
box addHorizontalLine.
"/ if there is no compiler around,
"/ change to compile nothing, and disable the checkBoxes
Compiler canCreateMachineCode ifFalse:[
stcCompilation selectionIndex:3.
compilationList disable.
].
].
box addCheckBox:(resources string:'allow underscore in identifiers') on:allowUnderscore.
box addVerticalSpace.
box addCheckBox:(resources string:'literal arrays are immutable') on:immutableArrays.
box addHorizontalLine.
box addCheckBox:(resources string:'warnings') on:warnings.
box addVerticalSpace.
box leftIndent:30.
warnSTXBox := box addCheckBox:(resources string:'ST/X language extensions') on:warnSTX.
box addVerticalSpace.
warnUnderscoreBox := box addCheckBox:(resources string:'underscores in identifiers') on:warnUnderscore.
box addVerticalSpace.
warnOldStyleBox := box addCheckBox:(resources string:'oldStyle assignment') on:warnOldStyle.
box addVerticalSpace.
box leftIndent:0.
box addAbortButton; addOkButton.
warnEnabler check.
box showAtPointer.
box accepted ifTrue:[
HistoryManager notNil ifTrue:[
historyLines value ifTrue:[
HistoryManager activate
] ifFalse:[
HistoryManager deactivate
].
].
Class catchMethodRedefinitions:catchRedefs value.
Compiler warnings:warnings value.
Compiler warnSTXSpecials:warnSTX value.
Compiler warnOldStyleAssignment:warnOldStyle value.
Compiler warnUnderscoreInIdentifier:warnUnderscore value.
Compiler allowUnderscoreInIdentifier:allowUnderscore value.
Compiler arraysAreImmutable:immutableArrays value.
Compiler stcCompilation:(stcCompilationOptions at:stcCompilation selectionIndex).
Compiler stcCompilationIncludes:stcIncludes value.
Compiler stcCompilationDefines:stcDefines value.
Compiler stcCompilationOptions:stcOptions value.
ObjectFileLoader notNil ifTrue:[
ObjectFileLoader searchedLibraries:(stcLibraries value asCollectionOfWords).
]
]
"Modified: 10.9.1995 / 19:19:18 / claus"
"Modified: 4.12.1995 / 01:11:23 / cg"
!
keyboardSetting
|mappings listOfRawKeys listOfFunctions
box l
list1 list2 listView1 listView2
frame selectionForwarder macroForwarder macroTextView y|
mappings := Screen current keyboardMap.
listOfRawKeys := (mappings keys asArray collect:[:key | key asString]) sort.
listOfFunctions := (mappings values asSet asArray collect:[:key | key asString]) sort.
selectionForwarder := Plug new.
selectionForwarder respondTo:#showFunction
with:[
|raw|
raw := list1 selection.
list2 retractInterrestFor:selectionForwarder.
list2 selection:(mappings at:raw asSymbol) asString.
list2 onChangeSend:#showRawKey to:selectionForwarder.
].
selectionForwarder respondTo:#showRawKey
with:[
|f raw|
f := list2 selection.
list1 retractInterrestFor:selectionForwarder.
raw := mappings keyAtValue:f asString.
raw isNil ifTrue:[
raw := mappings keyAtValue:f first.
raw isNil ifTrue:[
raw := mappings keyAtValue:f asSymbol.
]
].
list1 selection:raw.
list1 onChangeSend:#showFunction to:selectionForwarder.
].
macroForwarder := Plug new.
macroForwarder respondTo:#showMacro
with:[
|f macro indent|
f := list2 selection.
(f startsWith:'Cmd') ifTrue:[
f := f copyFrom:4
].
macro := FunctionKeySequences at:(f asSymbol) ifAbsent:nil.
macro notNil ifTrue:[
macro := macro asStringCollection.
indent := macro
inject:99999 into:[:min :element |
|stripped|
stripped := element withoutLeadingSeparators.
stripped size == 0 ifTrue:[
min
] ifFalse:[
min min:(element size - stripped size)
]
].
indent ~~ 0 ifTrue:[
macro := macro collect:[:line |
line size > indent ifTrue:[
line copyFrom:indent+1
] ifFalse:[
line
].
]
].
].
macroTextView contents:macro.
].
list1 := SelectionInList with:listOfRawKeys.
list1 onChangeSend:#showFunction to:selectionForwarder.
list2 := SelectionInList with:listOfFunctions.
list2 onChangeSend:#showRawKey to:selectionForwarder.
list2 onChangeSend:#showMacro to:macroForwarder.
box := Dialog new.
box label:(resources string:'Keyboard mappings').
l := box addTextLabel:(resources string:'KEY_MSG') withCRs.
l adjust:#left; borderWidth:0.
frame := View new.
frame extent:300 @ 300.
frame borderWidth:0.
listView1 := ScrollableView for:SelectionInListView in:frame.
listView1 model:list1.
listView1 origin:0.0@0.0 corner:0.5@1.0; inset:2.
listView2 := ScrollableView for:SelectionInListView in:frame.
listView2 model:list2.
listView2 origin:0.5@0.0 corner:1.0@1.0; inset:2.
frame topInset:box yPosition.
box addComponent:frame withExtent:350@200.
box makeTabable:listView1.
box makeTabable:listView2.
frame origin:0.0@0.0 corner:1.0@0.6.
box addVerticalSpace.
l := box addTextLabel:(resources string:'Macro text (if any):') withCRs.
l adjust:#left; borderWidth:0.
l origin:0.0@0.6 corner:1.0@0.6.
l topInset:(View viewSpacing).
l bottomInset:(l preferredExtent y negated - View viewSpacing).
macroTextView := HVScrollableView for:TextView miniScroller:true.
box addComponent:macroTextView tabable:true.
macroTextView origin:0.0@0.6 corner:1.0@1.0.
y := box yPosition.
box "addAbortButton;" addOkButton.
macroTextView topInset:(l preferredExtent y + 5).
macroTextView bottomInset:(box preferredExtent y - y).
box showAtPointer.
box accepted ifTrue:[
"no action yet ..."
]
!
languageSetting
|listOfLanguages box|
"
hardwiring here is stupid - need a resource file
which lists languagenames which have all texts available
in resource files ...
"
listOfLanguages := #('english'
'german'
'french'
'spanish'
'italian'
).
box := ListSelectionBox title:(resources string:'LANG_MSG') withCRs.
box label:(resources string:'Language selection').
box list:listOfLanguages.
box initialText:(Language).
box action:[:newLanguage |
self withWaitCursorDo:[
Transcript showCr:'change language to ' , newLanguage , ' ...'.
Smalltalk at:#Language put:newLanguage asSymbol.
Smalltalk changed:#Language.
ResourcePack flushCachedResourcePacks
].
self reopenLauncher.
].
box showAtPointer
!
messageSettings
|box vmInfo vmErrors displayErrors classInfos|
vmInfo := ObjectMemory infoPrinting asValue.
vmErrors := ObjectMemory debugPrinting asValue.
classInfos := Object infoPrinting asValue.
displayErrors := DeviceWorkstation errorPrinting asValue.
box := DialogBox new.
box label:(resources string:'Messages').
"/ box extent:200@300.
box addCheckBox:(resources string:'VM info messages') on:vmInfo.
box addCheckBox:(resources string:'VM error messages') on:vmErrors.
box addHorizontalLine.
box addCheckBox:(resources string:'Display error messages (Xlib, Xtlib ...)') on:displayErrors.
box addCheckBox:(resources string:'Other info messages') on:classInfos.
box addAbortButton; addOkButton.
box showAtPointer.
box accepted ifTrue:[
ObjectMemory infoPrinting:vmInfo value.
ObjectMemory debugPrinting:vmErrors value.
Object infoPrinting:classInfos value.
DeviceWorkstation errorPrinting:displayErrors value.
]
!
miscSettings
|box check logDoits shadows updChanges changeFileName
loadBinaries compileLazy hostNameInLabel y component|
logDoits := Smalltalk logDoits asValue.
shadows := PopUpView shadows asValue.
hostNameInLabel := StandardSystemView includeHostNameInLabel asValue.
updChanges := Class updatingChanges asValue.
changeFileName := ObjectMemory nameForChanges asValue.
loadBinaries := Smalltalk loadBinaries asValue.
compileLazy := Autoload compileLazy asValue.
box := DialogBox new.
box label:(resources string:'Other settings').
"/ box extent:200@300.
box addCheckBox:(resources string:'log compiles in changes file') on:updChanges.
box addCheckBox:(resources string:'log doIts in changes file') on:logDoits.
y := box yPosition.
component := box addTextLabel:(resources string:'change file:').
component width:0.5; adjust:#right; borderWidth:0.
box yPosition:y.
component := box addInputFieldOn:changeFileName tabable:true.
component width:0.5; left:0.5; immediateAccept:true; acceptOnLeave:false.
box addHorizontalLine.
box addCheckBox:(resources string:'lazy compilation when autoloading') on:compileLazy.
check := box addCheckBox:(resources string:'if present, load binary objects when autoloading') on:loadBinaries.
ObjectFileLoader isNil ifTrue:[
loadBinaries value:false.
check disable
].
box addHorizontalLine.
box addCheckBox:(resources string:'shadows under popup views') on:shadows.
box addCheckBox:(resources string:'hostname in window labels') on:hostNameInLabel.
box addAbortButton; addOkButton.
box showAtPointer.
box accepted ifTrue:[
Smalltalk logDoits:logDoits value.
PopUpView shadows:shadows value.
Class updateChanges:updChanges value.
Autoload compileLazy:compileLazy value.
Smalltalk loadBinaries:loadBinaries value.
StandardSystemView includeHostNameInLabel:hostNameInLabel value.
ObjectMemory nameForChanges:changeFileName value.
]
"Modified: 4.12.1995 / 01:10:49 / cg"
!
viewStyleSetting
|listOfStyles resourceDir dir box
list listView infoLabel infoForwarder newStyle|
"
search resources directory for a list of .style files ...
"
resourceDir := Smalltalk getSystemFileName:'resources'.
resourceDir isNil ifTrue:[
self warn:'no styles found (missing ''resources'' directory)'.
^ self
].
dir := FileDirectory directoryNamed:resourceDir.
listOfStyles := dir select:[:aFileName | aFileName endsWith:'.style'].
listOfStyles := listOfStyles collect:[:aFileName | aFileName copyWithoutLast:6].
listOfStyles sort.
"/ old code: used a standard ListSelectionBox
"/ changed to intercept selection and add info-output.
"/ box := ListSelectionBox title:(resources string:'STYLE_MSG') withCRs.
"/ box label:(resources string:'Style selection').
"/ box list:listOfStyles.
"/ box initialText:View defaultStyle.
"/ box selectAction:[:newStyle |
"/ ].
"/ box action:[:newStyle |
"/ transcript topView withCursor:Cursor wait do:[
"/ Transcript showCr:'change style to ' , newStyle , ' ...'.
"/ View defaultStyle:newStyle asSymbol.
"/ ]
"/ ].
"/ box showAtPointer
"/ new code: build box 'by 'hand'
"/
infoForwarder := Plug new.
infoForwarder respondTo:#showInfo
with:[
|nm sheet comment|
nm := list selection.
sheet := ViewStyle fromFile:(nm , '.style').
comment := sheet at:#comment ifAbsent:''.
infoLabel label:comment withCRs asStringCollection
].
list := SelectionInList with:listOfStyles.
list onChangeSend:#showInfo to:infoForwarder.
box := Dialog new.
box label:(resources string:'Style selection').
(box addTextLabel:(resources string:'STYLE_MSG') withCRs) borderWidth:0.
listView := SelectionInListView on:list.
listView doubleClickAction:[:sel | box accept value:true. box hide].
listView height:200.
box addComponent:(ScrollableView forView:listView) tabable:true.
box addVerticalSpace.
(infoLabel := box addTextLabel:'\\' withCRs) adjust:#centerLeft; borderWidth:0.
box addAbortButton; addOkButton.
list selection:(View defaultStyle).
box extent:(box preferredExtent).
box minExtent:box extent.
box maxExtent:box extent.
box showAtPointer.
box accepted ifTrue:[
newStyle := list selection.
newStyle notNil ifTrue:[
self withWaitCursorDo:[
Transcript showCr:'change style to ' , newStyle , ' ...'.
View defaultStyle:newStyle asSymbol.
].
self reopenLauncher.
]
]
! !
!NewLauncher methodsFor:'actions - tools'!
fullScreenHardcopy
"after a second (to allow redraw of views under menu ...),
save the contents of the whole screen."
Processor addTimedBlock:[
self saveScreenImage:(Image fromScreen) defaultName:'screen'
] afterSeconds:1
!
removeAllBreakAndTracePoints
MessageTracer cleanup
!
screenHardcopy
"after a second (to allow redraw of views under menu ...),
let user specify a rectangular area on the screen
and save its contents."
|area|
Processor addTimedBlock:[
area := Rectangle fromUser.
(area width > 0 and:[area height > 0]) ifTrue:[
self saveScreenImage:(Image fromScreen:area) defaultName:'hardcopy'
]
] afterSeconds:1
!
startEventMonitor
EventMonitor open
!
startFullWindowTreeView
WindowTreeView open
!
startMemoryMonitor
MemoryMonitor open
!
startMemoryUsageView
MemoryUsageView open
!
startProcessMonitor
ProcessMonitor open
!
startWindowTreeView
|v|
v := self pickAView.
v notNil ifTrue:[
WindowTreeView openOn:v topView
]
!
viewDestroy
"let user pick a view and destroy it.
Even allow destroying non-smalltalk views
(also for views which I forgot due to some error)"
|device p v id|
(Delay forSeconds:1) wait.
device := Screen current.
p := device pointFromUser.
id := device viewIdFromPoint:p.
v := device viewFromId:id.
v notNil ifTrue:[
v topView destroy.
^ self
].
id = device rootView id ifTrue:[
^ self
].
(Dialog confirm:'mhmh, this may not a be smalltalk view.\Destroy anyway ?' withCRs)
ifTrue:[
device destroyView:nil withId:id
].
"Modified: 18.9.1995 / 23:13:32 / claus"
!
viewHardcopy
"after a second (to allow redraw of views under menu ...),
let user specify a view and save its contents."
Processor addTimedBlock:[
|v|
v := Screen current viewFromUser.
v notNil ifTrue:[
self saveScreenImage:(Image fromView:(v topView)) defaultName:'hardcopy'
]
] afterSeconds:1
!
viewInspect
"let user pick a view and inspect it. Only smalltalk views are allowed"
|v|
v := self pickAView.
v notNil ifTrue:[
"/ v topView inspect
v inspect
]
! !
!NewLauncher methodsFor:'change & update'!
update:something with:aParameter from:changedObject
((something == #currentProject)
or:[changedObject == Project]) ifTrue:[
self changed:#info.
^ self
].
! !
!NewLauncher methodsFor:'help'!
helpTextFor:aComponent
|sel s|
aComponent == transcript ifTrue:[
s := 'TRANSCRIPT_HELP'
].
aComponent == infoView ifTrue:[
s := 'INFOVIEW_HELP'
].
(buttonPanel subViews includes:aComponent) ifTrue:[
"kludge: look for its change selector"
sel := aComponent changeMessage.
sel == #startSystemBrowser ifTrue:[
s := 'SBROWSER_BUTTON_HELP'
].
sel == #startFileBrowser ifTrue:[
s := 'FBROWSER_BUTTON_HELP'
].
sel == #startChangesBrowser ifTrue:[
s := 'CBROWSER_BUTTON_HELP'
].
].
s notNil ifTrue:[
^ resources string:s
].
^ nil
! !
!NewLauncher methodsFor:'infoview update'!
info
|project projectName projectDir packageName|
(Project isNil or:[(project := Project current) isNil]) ifTrue:[
projectName := '* none *'.
projectDir := '.'.
packageName := '* none *'.
] ifFalse:[
projectName := project name.
projectDir := project directory.
packageName := project packageName.
].
^ resources
string:'project: ''%1'' fileOut to: ''%3'' package: ''%2'''
withArgs:(Array
with:projectName
with:packageName
with:(projectDir contractTo:30))
! !
!NewLauncher methodsFor:'initialize / release'!
addTopViewsToCurrentProject
"ignored here - the launcher is always global (i.e. not project private)."
^ self
!
buttonPanelSpec
"return a spec for the buttons in the panel;
entries consists of selector and bitmap-filename.
nil selectors are taken as separators (see setupButtonPanel)"
^ #(
#(startSystemBrowser 'SBrowser32x32.xbm')
#(startFileBrowser 'FBrowser32x32.xbm')
#(startWorkspace 'Workspace32x32.xbm')
#(nil nil)
#(startChangesBrowser 'CBrowser32x32.xbm')
"/ #(nil nil)
"/ #(nil nil)
"/ #(startDocumentationTool 'book11.ico')
)
"Created: 4.12.1995 / 20:16:18 / cg"
!
closeRequest
(self confirm:(resources string:'really close %1 ?' with:self class name)) ifTrue:[
super closeRequest
]
!
focusSequence
^ (Array with:myMenu)
,
(buttonPanel subViews select:[:element | element isKindOf:Button])
"/ , (Array with:Transcript)
!
openInterface
"sent by my superclass to open up my interface"
|top icn w|
top := StandardSystemView new.
top label:'Smalltalk/X'; iconLabel:'ST/X Launcher'.
top extent:(400@300 ).
"
temporary kludge for SGI;
this will be moved into StandardSystemView and be done
automatically soon ...
"
Screen current serverVendor = 'Silicon Graphics' ifTrue:[
icn := self class aboutIcon.
icn notNil ifTrue:[
icn := icn magnifiedTo:86@68.
w := View extent:86@68. "/ icn extent.
w viewBackground:icn.
top iconView:w
]
].
self setupViewsIn:top.
top application:self.
builder window:top.
"
open with higher prio to allow interaction even while things
are running ...
"
top openWithPriority:(Processor userSchedulingPriority + 1).
!
release
infoProcess notNil ifTrue:[
infoProcess terminate.
infoProcess := nil.
].
super release
!
restarted
"image restart - since WindowGroup recreates the process with
default prio, we have to raise the prio again.
Mhmh - this looks like a bug to me ..."
Processor activeProcess priority:(Processor userSchedulingPriority + 1).
super restarted
!
saveAndTerminate
"
some windowManagers can send this, to shutDown an application
but let it save its state before, for restart. We are already
prepared for this ;-)"
self snapshot.
super saveAndTerminate
!
setupButtonPanelIn:aTopView
"create the buttonPanel"
|spc mh|
spc := View viewSpacing // 2.
buttonPanel := HorizontalPanelView in:aTopView.
buttonPanel level:-1; borderWidth:0.
buttonPanel horizontalLayout:#leftSpace.
self buttonPanelSpec do:[:entry |
|sel b sep|
sel := entry at:1.
sel isNil ifTrue:[
sep := View in:buttonPanel.
sep extent:32@1; borderWidth:0.
] ifFalse:[
b := Button in:buttonPanel.
b form:(Image fromFile:(entry at:2)).
b model:self; changeMessage:sel
]
].
mh := myMenu height.
buttonPanel origin:0.0 @ (mh + spc)
corner:(1.0 @ (mh + spc + buttonPanel preferredExtent y)).
buttonPanel leftInset:spc; rightInset:spc.
!
setupDemoMenu
"setup the demo pulldown menu"
|m|
myMenu at:#demos
putLabels:(resources array:#(
'goodies'
'games'
'geometric designs'
'simple animations'
'3D graphics'
'graphic editors'
))
selectors:#(
goodies
games
geometricDesigns
simpleAnimations
#'3Dgraphics'
#graphicEditors
)
receiver:self.
"
only to show two different ways of defining a popUpMenu,
we use labels:selectors:receiver: here:
"
m := myMenu menuAt:#demos.
m subMenuAt:#games
put:(PopUpMenu
labels:(resources array:#(
'Tetris'
'Tic Tac Toe'
'Tic Tac Toe (2 players)'
))
selectors:#(
startTetris
startTicTacToe
startTicTacToe2
)
receiver:self).
"
and labels:selector:args:receiver: here:
"
m subMenuAt:#geometricDesigns
put:(PopUpMenu
labels:(resources array:#(
'Pen demo'
'Commander demo'
'-'
'Fractal plants demo'
'Fractal patterns demo'
))
selector:#openDemo:
args:#(
PenDemo
CommanderDemo
nil
FractalPlantsDemo
FractalPatternsDemo
)
receiver:self).
m subMenuAt:#simpleAnimations
put:(PopUpMenu
labels:(resources array:#(
'Animation'
'Globe demo'
))
selector:#openDemo:
args:#(
Animation
GlobeDemo
)
receiver:self).
m subMenuAt:#'3Dgraphics'
put:(PopUpMenu
labels:(resources
array:#(
'plane'
'tetra'
'cube (wireframe)'
'cube (solid)'
'sphere (wireframe)'
'doughnut (wireframe)'
'planet'
'teapot'
'logo'
'x/y graph'
'-'
'cube (light)'
'cube (light & texture)'
'sphere (light)'
'colored octahedron'
))
selector:#openDemo:
args:#(
GLPlaneDemoView2
GLTetraDemoView
GLWireCubeDemoView
GLCubeDemoView
GLWireSphereDemoView
GLDoughnutDemoView
GLPlanetDemoView
GLTeapotDemo
Logo3DView1
GLXYGraph
nil
GLCubeDemoView2
GLBrickCubeDemoView
GLSphereDemoView2
GLOctaHedronDemoView
)
receiver:self).
m subMenuAt:#graphicEditors
put:(PopUpMenu
labels:(resources array:#(
'DrawTool'
'LogicTool'
))
selector:#openDemo:
args:#(
DrawTool
LogicTool
)
receiver:self).
m subMenuAt:#goodies
put:(PopUpMenu
labels:(resources array:#(
'clock'
'calendar'
'-'
'mail tool'
'news tool'
))
selector:#openDemo:
args:#(
Clock
Calendar
nil
MailView
NewsView
)
receiver:self).
!
setupInfoViewIn:topView
|spc halfSpc|
spc := View viewSpacing.
infoView := Label label:'' in:topView.
infoView adjust:#left; borderWidth:0.
infoView level:-1.
transcript superView bottomInset:(infoView height + spc).
infoView is3D ifTrue:[
halfSpc := spc // 2.
] ifFalse:[
halfSpc := 0
].
infoView topInset:(infoView height negated - spc + transcript borderWidth);
bottomInset:halfSpc;
leftInset:halfSpc;
rightInset:halfSpc.
infoView origin:0.0 @ 1.0 corner:1.0 @ 1.0.
infoView model:self; aspect:#info; labelMessage:#info.
Project notNil ifTrue:[
Project addDependent:self.
]
"
NewLauncher open
"
!
setupMenu
"setup the pulldown menu"
|l s icon|
myMenu labels:(resources array:#(
'about'
'file'
'classes'
'tools'
'projects'
'settings'
'demos'
'help')).
"
if there is a bitmap, change 'about' to the ST/X icon
"
icon := self class smallAboutIcon.
icon notNil ifTrue:[
myMenu labels at:1 put:icon.
myMenu height:(myMenu height max:(icon height + (View viewSpacing * 2)))
].
myMenu selectors:#(
#about
#file
#classes
#tools
#projects
#settings
#demos
#help).
myMenu at:#about
putLabels:(resources array:#(
'about Smalltalk/X ...'
))
selectors:#(
#about
)
receiver:self.
l := #(
'file browser'
'-'
'modules'
'-'
'snapshot'
'snapshot & exit'
'exit smalltalk'
).
s := #(
#startFileBrowser
nil
#objectModuleDialog
nil
#snapshot
#snapshotAndExit
#exit
).
myMenu at:#file
putLabels:(resources array:l)
selectors:s
receiver:self.
myMenu at:#classes
putLabels:(resources array:#(
'system browser'
'class browser'
'full class browser'
'class hierarchy browser'
'class tree'
'-'
'implementors'
'senders'
'-'
'change browser'
))
selectors:#(
#startSystemBrowser
#startClassBrowser
#startFullClassBrowser
#startClassHierarchyBrowser
#startClassTreeView
nil
#browseImplementors
#browseSenders
nil
#startChangesBrowser
)
receiver:self.
myMenu at:#projects
putLabels:(resources array:#(
'new project'
'-'
'select project ...'
))
selectors:#(
#newProject
nil
#selectProject
)
receiver:self.
myMenu at:#settings
putLabels:(resources array:#(
'language'
'show keyboard mappings'
'view style'
'messages'
'compilation'
'misc'
))
selectors:#(
#languageSetting
#keyboardSetting
#viewStyleSetting
#messageSettings
#compilerSettings
#miscSettings
)
receiver:self.
self setupToolsMenu.
self setupDemoMenu.
ActiveHelp notNil ifTrue:[
l := #(
'\c active help'
'ST/X documentation'
).
s := #(
#toggleActiveHelp:
#startDocumentationTool
)
] ifFalse:[
l := #(
'ST/X documentation'
).
s := #(
#startDocumentationTool
)
].
myMenu at:#help
putLabels:(resources array:l)
selectors:s
receiver:self.
(ActiveHelp notNil
and:[ActiveHelp isActive]) ifTrue:[
(myMenu menuAt:#help) checkToggleAt:#toggleActiveHelp: put:true
].
!
setupOtherViewsIn:aTopView
"a hook - allows redefinition in your personal subclass.
For example, add a clock:"
"
|sz clock space halfSpace|
sz := buttonPanel innerHeight - (buttonPanel level abs*2).
space := View viewSpacing.
halfSpace := space // 2.
buttonPanel rightInset:sz+(space * 2).
clock := ClockView in:buttonPanel topView.
clock borderWidth:1.
clock showSeconds:false.
clock extent:(sz @ sz).
clock origin:(1.0 @ (buttonPanel origin y + halfSpace)).
clock leftInset:sz negated - 2 - halfSpace.
clock rightInset:halfSpace.
clock level:1.
"
!
setupToolsMenu
"setup the tools pulldown menu"
|m|
myMenu at:#tools
putLabels:(resources array:#(
'workspace'
'-'
'monitors'
'-'
'view tree (all views)'
'view tree'
'inspect view'
'destroy view'
'-'
'hardcopy'
'-'
'misc'
))
selectors:#(
#startWorkspace
nil
#monitors
nil
#startFullWindowTreeView
#startWindowTreeView
#viewInspect
#viewDestroy
nil
#hardcopy
nil
#misc
)
receiver:self.
m := myMenu menuAt:#tools.
m subMenuAt:#monitors
put:(PopUpMenu
labels:(resources array:#(
'process'
'memory'
'event'
'-'
'memory usage'
))
selectors:#(
#startProcessMonitor
#startMemoryMonitor
#startEventMonitor
nil
#startMemoryUsageView
)
receiver:self).
m subMenuAt:#misc
put:(PopUpMenu
labels:(resources array:#(
'remove all break/trace points'
))
selectors:#(
#removeAllBreakAndTracePoints
)
receiver:self).
m subMenuAt:#hardcopy
put:(PopUpMenu
labels:(resources array:#(
'screen'
'area'
'view'
))
selectors:#(
#fullScreenHardcopy
#screenHardcopy
#viewHardcopy
)
receiver:self).
!
setupTranscriptIn:aView
|v|
(Transcript notNil and:[Transcript ~~ Stderr]) ifTrue:[
Transcript topView destroy.
].
v := HVScrollableView
for:TextCollector
miniScrollerH:true
miniScrollerV:false
in:aView.
v origin:(0.0 @ (buttonPanel corner y + View viewSpacing))
corner:(1.0 @ 1.0).
transcript := v scrolledView.
transcript beTranscript.
!
setupViewsIn:topView
"create the pulldown menu, buttonPanel and transcript view"
|tFont|
topView model:self.
myMenu := PullDownMenu in:topView.
myMenu origin:0.0 @ 0.0 corner:(1.0 @ myMenu height).
self setupMenu.
self setupButtonPanelIn:topView.
self setupTranscriptIn:topView.
self setupInfoViewIn:topView.
self setupOtherViewsIn:topView.
tFont := transcript font.
topView extent:(((tFont widthOf:'3')*60) max:myMenu preferredExtent x)
@
((tFont height) * 20).
"
NewLauncher open
"
! !
!NewLauncher methodsFor:'private'!
pickAView
|v|
(Delay forSeconds:1) wait.
v := Screen current viewFromUser.
v isNil ifTrue:[
self warn:'sorry, this is not a smalltalk view'.
^ nil
].
^ v
!
reopenLauncher
"for now (since style & language settings currently do
not affect living views ...)"
|contents|
contents := Transcript endEntry; contents.
self class open.
Transcript contents:contents; hideCursor; scrollToBottom; cursorToEnd; showCursor
!
saveAllViews
"tell each topview that we are going to terminate and give it chance
to save its contents."
ObjectMemory changed:#aboutToExit
!
saveScreenImage:anImage defaultName:defaultName
"save an image into a file
- ask user for filename using a fileSelectionBox."
|fileName|
fileName := Dialog
requestFileName:'save image in:'
default:(defaultName , '.tiff')
ok:'save'
abort:'abort'
pattern:'*.tiff'.
fileName notNil ifTrue:[
anImage saveOn:fileName
].
! !
!NewLauncher methodsFor:'queries'!
processName
"for monitors only - my name"
^ 'ST/X Launcher'
! !
!NewLauncher class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libtool/Launcher.st,v 1.59 1995-12-05 13:28:58 cg Exp $'
! !