# HG changeset patch # User Claus Gittinger # Date 938969705 -7200 # Node ID fc64935b7ff91cccb00d3809db9927f2e97a5bb4 # Parent 6fb170b753029d96643251d92a056139d8f8a27b *** empty log message *** diff -r 6fb170b75302 -r fc64935b7ff9 ProjectBrowser.st --- a/ProjectBrowser.st Sat Oct 02 15:27:55 1999 +0200 +++ b/ProjectBrowser.st Sun Oct 03 18:55:05 1999 +0200 @@ -1849,7 +1849,7 @@ #name: 'ProjectBrowser' #min: #(#Point 10 10) #max: #(#Point 1024 768) - #bounds: #(#Rectangle 10 20 613 571) + #bounds: #(#Rectangle 509 332 1112 883) #menu: #mainMenu #icon: #bigProjectBrowserIcon ) @@ -1862,47 +1862,59 @@ #menu: #menu #textDefault: true ) - #(#VariableHorizontalPanelSpec - #name: 'VariableHorizontalPanel1' - #layout: #(#LayoutFrame 0 0.0 40 0.0 0 1.0 -24 1.0) - #handles: - #(#OrderedCollection - #Any 0.379433 - 1.0 - ) + #(#VariableVerticalPanelSpec + #name: 'VariableVerticalPanel1' + #layout: #(#LayoutFrame 0 0.0 32 0.0 0 1.0 -24 1.0) + #level: 1 #component: #(#SpecCollection #collection: #( - #(#SelectionInTreeViewSpec - #name: 'TreeList1' - #model: #selectedTreeNodeHolder - #menu: #itemMenuHolder - #performer: #itemMenuPerformer - #hasHorizontalScrollBar: true - #hasVerticalScrollBar: true - #miniScrollerHorizontal: true - #showRoot: false - #showDirectoryIndicatorForRoot: false - #showDirectoryIndicator: true - #valueChangeSelector: #itemSelected: - #doubleClickSelector: #itemDoubleClicked: - #hierarchicalList: #projectTreeHolder - #selectConditionSelector: #selectionChangeAllowed: - #highlightMode: #label + #(#VariableHorizontalPanelSpec + #name: 'VariableHorizontalPanel1' + #component: + #(#SpecCollection + #collection: #( + #(#SelectionInTreeViewSpec + #name: 'TreeList1' + #model: #selectedTreeNodeHolder + #menu: #itemMenuHolder + #performer: #itemMenuPerformer + #hasHorizontalScrollBar: true + #hasVerticalScrollBar: true + #miniScrollerHorizontal: true + #showRoot: false + #showDirectoryIndicatorForRoot: false + #showDirectoryIndicator: true + #valueChangeSelector: #itemSelected: + #doubleClickSelector: #itemDoubleClicked: + #hierarchicalList: #projectTreeHolder + #selectConditionSelector: #selectionChangeAllowed: + #highlightMode: #label + ) + #(#SubCanvasSpec + #name: 'SubCanvas1' + #hasHorizontalScrollBar: false + #hasVerticalScrollBar: false + #specHolder: #currentCanvasHolder + ) + ) + + ) + #handles: #(#Any 0.389718 1.0) ) - #(#SubCanvasSpec - #name: 'SubCanvas1' - #hasHorizontalScrollBar: false - #hasVerticalScrollBar: false - #specHolder: #currentCanvasHolder + #(#ArbitraryComponentSpec + #name: 'ArbitraryComponent1' + #hasBorder: false ) ) ) + #handles: #(#Any 0.987879 1.0) ) #(#UISubSpecification #name: 'infoBarSubSpec' #layout: #(#LayoutFrame 0 0.0 -24 1 0 1.0 0 1.0) + #level: 1 #majorKey: #ToolApplicationModel #minorKey: #windowSpecForInfoBar ) @@ -2122,6 +2134,33 @@ #value: #checkInProject #enabled: #hasProjectSelectedAndProjectFilenameHolderAndProjectCodeIsLoaded ) + #(#MenuItem + #label: '-' + ) + #(#MenuItem + #label: 'CheckIn Classes' + #translateLabel: true + #value: #checkInAllClasses + #enabled: #hasProjectSelectedAndProjectFilenameHolderAndProjectCodeIsLoaded + ) + #(#MenuItem + #label: 'CheckIn Extensions' + #translateLabel: true + #value: #checkInMethods + #enabled: #hasProjectSelectedAndProjectFilenameHolderAndProjectCodeIsLoaded + ) + #(#MenuItem + #label: 'CheckIn Project File' + #translateLabel: true + #value: #checkInProjectFile + #enabled: #hasProjectSelectedAndProjectFilenameHolderAndProjectCodeIsLoaded + ) + #(#MenuItem + #label: 'CheckIn Makefiles' + #translateLabel: true + #value: #checkInMakefiles + #enabled: #hasProjectSelectedAndProjectFilenameHolderAndProjectCodeIsLoaded + ) ) nil nil @@ -2277,6 +2316,24 @@ #translateLabel: true #value: #browseMethodFull ) + #(#MenuItem + #label: '-' + ) + #(#MenuItem + #label: 'Remove...' + #translateLabel: true + #value: #removeMethod + ) + #(#MenuItem + #label: 'Remove from Project...' + #translateLabel: true + #value: #removeMethodFromProject + ) + #(#MenuItem + #label: 'Move to Project...' + #translateLabel: true + #value: #moveMethodToProject + ) ) nil nil @@ -4055,6 +4112,20 @@ "Modified: / 23.3.1999 / 14:18:38 / cg" ! +selectedMethod + |node methodInfo classOrClassName cls mthd text| + + self hasMethodNodeSelected ifFalse:[^ nil]. + + node := self selectedTreeNode. + methodInfo := node contents value. + mthd := methodInfo method. + mthd isNil ifTrue:[ + self valueOfInfoLabel value:'The method is not (yet) loaded.'. + ]. + ^ mthd +! + updateProjectTree |tree moduleRoots root showWhat| @@ -4262,44 +4333,8 @@ !ProjectBrowser methodsFor:'user actions'! -addClass - "ask fo, and add a single class" - - |p className cls| - - p := self currentProject. - - className := Dialog request:'Class to add:'. - className size == 0 ifTrue:[^ self]. - cls := Smalltalk classNamed:className. - cls isNil ifTrue:[ - "/ a new one - (self confirm:'This is a new class. Add ?') ifFalse:[ - ^ self - ]. - p - addClass:className - classFileName:((Smalltalk fileNameForClass:className) , '.st'). - ] ifFalse:[ - cls package ~= p package ifTrue:[ - "/ a new one - (self confirm:'Change the classes package from ' , cls package , ' to ' , p package , ' ?') ifFalse:[ - ^ self - ]. - cls package:p package. - ]. - p - addClass:cls name - classFileName:(cls classFilename - ? ((Smalltalk fileNameForClass:cls) , '.st')). - ]. - - self updateClassListForProject:p - -! - addClasses - "ask fo, and add a single class" + "ask for, and add a single class" |p className cls oldPackage| @@ -4340,343 +4375,6 @@ ! -addClassesFromFilesInDirectory - self addClassesFromFilesInDirectoryWithFilter:nil -! - -addClassesFromFilesInDirectoryIfPresentInImage - self addClassesFromFilesInDirectoryWithFilter:[:classOrName | classOrName isBehavior] - -! - -addClassesFromFilesInDirectoryWithFilter:aFilterBlockOrNil - |project existingClasses prjDirectory anyChange numSTFilesFound| - - project := self currentProject. - - existingClasses := project classInfo. - anyChange := false. - numSTFilesFound := 0. - - prjDirectory := project directory asFilename. - (prjDirectory exists and:[prjDirectory isDirectory]) ifFalse:[ - self warn:'Invalid project directory: ' , prjDirectory pathName. - ^ self - ]. - - prjDirectory directoryContents do:[:fn | - |f oldInfo cls| - - f := prjDirectory construct:fn. - (f hasSuffix:'st') ifTrue:[ - numSTFilesFound := numSTFilesFound + 1. - - oldInfo := existingClasses - detect:[:clsInfo | - clsInfo classFileName = fn - ] - ifNone:nil. - oldInfo isNil ifTrue:[ - "/ extract className from fileName ... - cls := Smalltalk filenameAbbreviations keyAtValue:(f withoutSuffix baseName ). - cls isNil ifTrue:[ - cls := f withoutSuffix baseName asSymbol. - project defaultNameSpace notNil ifTrue:[ - cls := (project defaultNameSpace name , '::' , cls) asSymbol - ] - ]. - (aFilterBlockOrNil isNil - or:[aFilterBlockOrNil value:cls]) ifTrue:[ - project addClass:cls classFileName:fn. - anyChange := true. -Transcript showCR:'added ' , fn , ' as class: ' , cls printString. - ] ifFalse:[ -Transcript showCR:'skipped ' , fn , ' as class: ' , cls printString. - ] - - ] - ] - ]. - - anyChange ifTrue:[ - self updateClassListForProject:project - ] ifFalse:[ - numSTFilesFound == 0 ifTrue:[ - self information:'No st-sourcefiles found in ' , prjDirectory pathName. - ] - ] -! - -addClassesFromImage - "add classes with this packageId found in the image" - - |project| - - project := self currentProject. - Smalltalk allClassesDo:[:aClass | - aClass isMeta ifFalse:[ - (aClass isNamespace not or:[aClass == Smalltalk]) ifTrue:[ - aClass package = project package ifTrue:[ - (project classInfoFor:aClass) isNil ifTrue:[ - project - addClass:aClass name - classFileName:(aClass classFilename - ? ((Smalltalk fileNameForClass:aClass) , '.st')). - ] - ] - ] - ] - ]. - - self updateClassListForProject:project - -! - -browseClasses - |ns p classes nBad uniqueClasses| - - p := self currentProject. - classes := p classes - collect:[:clsOrName | - |cls realName| - - clsOrName isSymbol ifTrue:[ - realName := clsOrName. - (realName includes:$:) ifTrue:[ - (realName startsWith:'Smalltalk::') ifTrue:[ - realName := (realName copyFrom:'Smalltalk::' size + 1) asSymbol - ] - ]. - cls := Smalltalk at:realName - ] ifFalse:[ - cls := clsOrName - ]. - cls - ]. - - "/ remove duplicates - but want to preserve order - "/ thats why we do not use asIdentitySet asOrderedCollection - uniqueClasses := OrderedCollection new. - classes do:[:cls | (uniqueClasses includesIdentical:cls) ifFalse:[uniqueClasses add:cls]]. - - nBad := classes inject:0 into:[:sum :el | el isNil ifTrue:[sum+1] ifFalse:[sum]]. - nBad ~~ 0 ifTrue:[ - classes := classes select:[:cls | cls notNil]. - self warn:('Oops - %1 classes could not be found.\\You should probably load them first.' bindWith:nBad) withCRs. - ]. - - - SystemBrowser - browseClasses:classes title:('Classes in ' , p name) sort:true. - - - -! - -buildAll - |p| - - p := self currentProject. - p isNil ifTrue:[ - self information:'No project selected'. - ^ self - ]. - - self withCursor:Cursor wait do:[ - "/ prepare the building ... - - (p propertyAt:#deliverLoadAllFile) == true ifTrue:[ - p createLoadAllFile - ]. - - (p propertyAt:#deliverSources) == true ifTrue:[ - p createSourceFiles - ]. - - (p propertyAt:#deliverMakefiles) == true ifTrue:[ - self buildMakefiles - ]. - - (p propertyAt:#deliverCompiledBinary) == true ifTrue:[ - self buildCompiledClassLibrary - ]. - - (p propertyAt:#deliverByteCode) == true ifTrue:[ - self buildByteCodeClassLibrary - ]. - - "/ now, deploy ... - - (p propertyAt:#deliverZipArchive) == true ifTrue:[ - p buildZipArchive - ]. - - (p propertyAt:#deliverTarArchive) == true ifTrue:[ - p buildTarArchive - ]. - - (p propertyAt:#deliverGZipArchive) == true ifTrue:[ - p buildGZipArchive - ]. - ]. - - -! - -buildCompiledClassLibrary - "compile a binary class library in the projects directory" - |p diagnosticFile diagnostic error textBox| - - p := self currentProject. - p isNil ifTrue:[ - self information:'No project selected'. - ^ self - ]. - - "/ check for directory ... - (self checkForProjectDirectoryFor:p) ifFalse:[ - ^ self - ]. - - "/ check for Make.proto ... - (self checkForMakeProtoFor:p) ifFalse:[ - ^ self - ]. - - "/ check for Makefile ... - (self checkForMakefileFor:p) ifFalse:[ - ^ self - ]. - - "/ now, execute the makefile found there ... - diagnosticFile := Filename newTemporary. - diagnostic := diagnosticFile writeStream. - error := false. - - [ - self withCursor:Cursor wait do:[ - OperatingSystem - executeCommand:'make' - inputFrom:nil - outputTo:diagnostic - errorTo:diagnostic - inDirectory:(p directory asFilename pathName) - onError:[error := true]. - ]. - - diagnostic close. - - textBox := TextBox new. - textBox initialText:(diagnosticFile readStream contents). - textBox title:'Make Diagnostic output:'. - textBox readOnly:true. - textBox noCancel. - textBox label:'Make Diagnostic output'. - textBox extent:(600@250); sizeFixed:true. - textBox showAtPointer. - - ] valueNowOrOnUnwindDo:[ - diagnosticFile delete - ]. - - -! - -buildLoadAllFile - |p | - - p := self currentProject. - p isNil ifTrue:[ - self information:'No project selected'. - ^ self - ]. - - self withCursor:Cursor wait do:[ - p createLoadAllFile. - ] -! - -buildMakefiles - |p | - - p := self currentProject. - p isNil ifTrue:[ - self information:'No project selected'. - ^ self - ]. - - self withCursor:Cursor wait do:[ - p createProtoMakefile. - p createMakefile - ]. -! - -checkInProject - |p classes methods anyMethodMissing| - - p := self currentProject. - p isNil ifTrue:[ - self information:'No project selected'. - ^ self - ]. - - "/ check in classes ... - - classes := p classes. - classes do:[:aClass | - |clsName| - - aClass isBehavior ifFalse:[ - aClass isSymbol ifTrue:[ - clsName := aClass - ] ifFalse:[ - clsName := aClass className - ]. - Transcript showCR:('ProjectBrowser: cannot checkIn unloaded class: ' , clsName). - ] ifTrue:[ - aClass isLoaded ifFalse:[ - Transcript showCR:('ProjectBrowser: cannot checkIn unloaded class: ' , aClass name). - ] ifTrue:[ - aClass owningClass isNil ifTrue:[ "/ skip private classes - Transcript showCR:('ProjectBrowser: checking in class: ' , aClass name). - self checkInClass:aClass. - ] - ] - ] - ]. - - "/ check methods ... - - anyMethodMissing := false. - methods := p methods. - methods size > 0 ifTrue:[ - methods do:[:aMethod | - aMethod isMethod ifFalse:[ - Transcript showCR:('ProjectBrowser: cannot checkIn unloaded method: ' , aMethod className , ' ' , aMethod methodName). - anyMethodMissing := true. - ] - ]. - anyMethodMissing ifTrue:[ - Transcript showCR:'ProjectBrowser: cannot save method patches & extensions due to missing method(s)'. - ] ifFalse:[ - Transcript showCR:('ProjectBrowser: checking in patches & extensions'). - self checkInMethods:methods - ]. - ]. - - "/ check in the project file itself - self checkInProjectFile. - -! - -inspectCurrentProject - "inspect the current project" - - self hasProjectSelected ifTrue:[ - self currentProject inspect. - ] -! - itemDoubleClicked:index |node classOrClassName cls| @@ -4730,15 +4428,6 @@ "Modified: / 26.4.1999 / 22:49:20 / cg" ! -loadClassesFromDirectory - "load all classes as contained in the project into the system" - - self withReadCursorDo:[ - self currentProject loadClassesFromProjectDirectory. - ]. - -! - loadFromProjectFile:aFilenameString |oldNode newProject| @@ -4862,87 +4551,10 @@ ] ! -makeCurrentProject - "make the selected Project the current project" - - |project| - - self hasProjectSelected ifTrue:[ - project := self currentProject. - - Project current:project. - self showWhat value == #current ifTrue:[ - self updateProjectTree - ] - ] -! - methodPatchDoubleClick:arg self halt. ! -newProject - self newProject:Project new. - -! - -newProject:newProject - |newNode| - - newNode := self nodeFor:newProject. - self addProjectNodeToTree:newNode. - self projectTreeHolder root:projectTree. -"/ self projectTreeHolder selectNode:newNode. -"/ self projectTreeHolder expand:newNode. - - self readAspectsFromProject. - newProject wasLoadedFromFile ifFalse:[ - self updateListOfRequiredPrerequisiteClasses. - ] -! - -newSubProject - |projectNode subProjectsNode newNode parentProject newProject| - - projectNode := self currentProjectNode. - - projectNode notNil ifTrue:[ - parentProject := projectNode contents. - subProjectsNode := projectNode children detect:[:child | child contents == #subprojects]. -self halt. - parentProject notNil ifTrue:[ - newProject := Project new. - newNode := self nodeFor:newProject. - - parentProject addSubProject:newProject. - subProjectsNode add:newNode. - self projectTreeHolder root:projectTree. - self projectTreeHolder selectNode:newNode. - ] - ] - -! - -openDocumentation - self openHTMLDocument: 'tools/pbrowser/TOP.html' - -! - -openProject - |fn| - - fn := Dialog - requestFileName:'filename:' - default:nil - ifFail:nil - pattern:'*.prj' - fromDirectory:(FileSelectionBox lastFileSelectionDirectory). - - fn notNil ifTrue:[ - self loadFromProjectFile:fn. - ] -! - projectFilterChanged |theNode| @@ -4960,68 +4572,6 @@ ]. ! -removeProject - |projectToRemove selectedNode subNode newNode parentNode parentProject newProject| - - self hasProjectNodeSelected ifTrue:[ - selectedNode := self selectedTreeNode. - projectToRemove := selectedNode contents. - - (self confirm:'Really remove the project ?') ifTrue:[ - self withExecuteCursorDo:[ - self projectTreeHolder removeSelection. - projectToRemove removeFromSystem. - ] - ] - ] -! - -renameProject - |nm projectNode selectedProject| - - projectNode := self currentProjectNode. - projectNode notNil ifTrue:[ - selectedProject := projectNode contents. - - nm := Dialog - request:'Rename to:' - initialAnswer:selectedProject name. - - nm size > 0 ifTrue:[ - selectedProject name:nm. -"/ selectedNode name:nm. -"/ selectedNode changed. - ] - ] -! - -saveProjectFile - |d p| - - self modifiedChannel value ifTrue:[ - (self confirm:'Changes not confirmed; save anyway ?') ifFalse:[^ self] - ]. - - p := self currentProject. - p isNil ifTrue:[ - self information:'Select a project first.'. - ^self - ]. - p directory isNil ifTrue:[ - d := (Dialog request:'Project Directory:'). - d size == 0 ifTrue:[ - ^ self - ]. - p directory:d - ]. - - self withCursor:Cursor write do:[ - p saveAsProjectFile. - ] - - "Modified: / 26.4.1999 / 22:43:57 / cg" -! - selectionChangeAllowed:newNode |answer| @@ -5260,55 +4810,6 @@ l addAll:methodInfo. -! - -validateAgainstClassesInImage - "validate classes in project against classes found in the image" - - |project classesInProjectOnly classesInImageOnly bindings| - - project := self currentProject. - classesInImageOnly := IdentitySet new. - classesInProjectOnly := IdentitySet new. - - Smalltalk allClassesDo:[:aClass | - aClass isMeta ifFalse:[ - (aClass isNamespace not or:[aClass == Smalltalk]) ifTrue:[ - aClass package = project package ifTrue:[ - (project classInfoFor:aClass) isNil ifTrue:[ - classesInImageOnly add:aClass name. - ] - ] - ] - ] - ]. - project classInfo do:[:clsInfo | - |clsName cls| - - clsName := clsInfo className. - cls := Smalltalk at:clsName asSymbol. - (cls isBehavior not) ifTrue:[ - classesInProjectOnly add:clsName - ]. - ]. - - (classesInImageOnly isEmpty and:[classesInProjectOnly isEmpty]) ifTrue:[ - self information:'Set of classes in project and image are equal.'. - ^ self. - ]. - - classesInImageOnly := classesInImageOnly asOrderedCollection sort. - classesInProjectOnly := classesInProjectOnly asOrderedCollection sort. - - bindings := IdentityDictionary new. - bindings at:#classesInImageOnly put:classesInImageOnly. - bindings at:#classesInProjectOnly put:classesInProjectOnly. - - SimpleDialog - openDialogInterfaceSpec:(self class classValidationDialogSpec) - withBindings:bindings - - "Modified: / 26.9.1999 / 16:03:50 / cg" ! ! !ProjectBrowser methodsFor:'user actions - canvas'! @@ -5506,6 +5007,680 @@ self valueOfInfoLabel value:nil ! ! +!ProjectBrowser methodsFor:'user actions - menu'! + +addClass + "ask for, and add a single class" + + |p className cls| + + p := self currentProject. + + className := Dialog request:'Class to add:'. + className size == 0 ifTrue:[^ self]. + cls := Smalltalk classNamed:className. + cls isNil ifTrue:[ + "/ a new one + (self confirm:'This is a new class. Add ?') ifFalse:[ + ^ self + ]. + p + addClass:className + classFileName:((Smalltalk fileNameForClass:className) , '.st'). + ] ifFalse:[ + cls package ~= p package ifTrue:[ + "/ a new one + (self confirm:'Change the classes package from ' , cls package , ' to ' , p package , ' ?') ifFalse:[ + ^ self + ]. + cls package:p package. + ]. + p + addClass:cls name + classFileName:(cls classFilename + ? ((Smalltalk fileNameForClass:cls) , '.st')). + ]. + + self updateClassListForProject:p + +! + +addClassesFromFilesInDirectory + "add all classes found from files in the project directory" + + self addClassesFromFilesInDirectoryWithFilter:nil +! + +addClassesFromFilesInDirectoryIfPresentInImage + "add all classes found from files in the project directory, + but only if class is currently present in the image." + + self addClassesFromFilesInDirectoryWithFilter:[:classOrName | classOrName isBehavior] + +! + +addClassesFromFilesInDirectoryWithFilter:aFilterBlockOrNil + "helper to add all classes found from files in the project directory" + + |project existingClasses prjDirectory anyChange numSTFilesFound| + + project := self currentProject. + + existingClasses := project classInfo. + anyChange := false. + numSTFilesFound := 0. + + prjDirectory := project directory asFilename. + (prjDirectory exists and:[prjDirectory isDirectory]) ifFalse:[ + self warn:'Invalid project directory: ' , prjDirectory pathName. + ^ self + ]. + + prjDirectory directoryContents do:[:fn | + |f oldInfo cls| + + f := prjDirectory construct:fn. + (f hasSuffix:'st') ifTrue:[ + numSTFilesFound := numSTFilesFound + 1. + + oldInfo := existingClasses + detect:[:clsInfo | + clsInfo classFileName = fn + ] + ifNone:nil. + oldInfo isNil ifTrue:[ + "/ extract className from fileName ... + cls := Smalltalk filenameAbbreviations keyAtValue:(f withoutSuffix baseName ). + cls isNil ifTrue:[ + cls := f withoutSuffix baseName asSymbol. + project defaultNameSpace notNil ifTrue:[ + cls := (project defaultNameSpace name , '::' , cls) asSymbol + ] + ]. + (aFilterBlockOrNil isNil + or:[aFilterBlockOrNil value:cls]) ifTrue:[ + project addClass:cls classFileName:fn. + anyChange := true. +Transcript showCR:'added ' , fn , ' as class: ' , cls printString. + ] ifFalse:[ +Transcript showCR:'skipped ' , fn , ' as class: ' , cls printString. + ] + + ] + ] + ]. + + anyChange ifTrue:[ + self updateClassListForProject:project + ] ifFalse:[ + numSTFilesFound == 0 ifTrue:[ + self information:'No st-sourcefiles found in ' , prjDirectory pathName. + ] + ] +! + +addClassesFromImage + "add classes with this packageId found in the image" + + |project| + + project := self currentProject. + Smalltalk allClassesDo:[:aClass | + aClass isMeta ifFalse:[ + (aClass isNamespace not or:[aClass == Smalltalk]) ifTrue:[ + aClass package = project package ifTrue:[ + (project classInfoFor:aClass) isNil ifTrue:[ + project + addClass:aClass name + classFileName:(aClass classFilename + ? ((Smalltalk fileNameForClass:aClass) , '.st')). + ] + ] + ] + ] + ]. + + self updateClassListForProject:project + +! + +browseClasses + "browse the projects classes" + + |ns p classes nBad uniqueClasses| + + p := self currentProject. + classes := p classes + collect:[:clsOrName | + |cls realName| + + clsOrName isSymbol ifTrue:[ + realName := clsOrName. + (realName includes:$:) ifTrue:[ + (realName startsWith:'Smalltalk::') ifTrue:[ + realName := (realName copyFrom:'Smalltalk::' size + 1) asSymbol + ] + ]. + cls := Smalltalk at:realName + ] ifFalse:[ + cls := clsOrName + ]. + cls + ]. + + "/ remove duplicates - but want to preserve order + "/ thats why we do not use asIdentitySet asOrderedCollection + uniqueClasses := OrderedCollection new. + classes do:[:cls | (uniqueClasses includesIdentical:cls) ifFalse:[uniqueClasses add:cls]]. + + nBad := classes inject:0 into:[:sum :el | el isNil ifTrue:[sum+1] ifFalse:[sum]]. + nBad ~~ 0 ifTrue:[ + classes := classes select:[:cls | cls notNil]. + self warn:('Oops - %1 classes could not be found.\\You should probably load them first.' bindWith:nBad) withCRs. + ]. + + + SystemBrowser + browseClasses:classes title:('Classes in ' , p name) sort:true. + + + +! + +buildAll + "build all as specified in the deployment section" + + |p| + + p := self currentProject. + p isNil ifTrue:[ + self information:'No project selected'. + ^ self + ]. + + self withCursor:Cursor wait do:[ + "/ prepare the building ... + + (p propertyAt:#deliverLoadAllFile) == true ifTrue:[ + p createLoadAllFile + ]. + + (p propertyAt:#deliverSources) == true ifTrue:[ + p createSourceFiles + ]. + + (p propertyAt:#deliverMakefiles) == true ifTrue:[ + self buildMakefiles + ]. + + (p propertyAt:#deliverCompiledBinary) == true ifTrue:[ + self buildCompiledClassLibrary + ]. + + (p propertyAt:#deliverByteCode) == true ifTrue:[ + self buildByteCodeClassLibrary + ]. + + "/ now, deploy ... + + (p propertyAt:#deliverZipArchive) == true ifTrue:[ + p buildZipArchive + ]. + + (p propertyAt:#deliverTarArchive) == true ifTrue:[ + p buildTarArchive + ]. + + (p propertyAt:#deliverGZipArchive) == true ifTrue:[ + p buildGZipArchive + ]. + ]. + + +! + +buildCompiledClassLibrary + "compile a binary class library in the projects directory" + + |p diagnosticFile diagnostic error textBox| + + p := self currentProject. + p isNil ifTrue:[ + self information:'No project selected'. + ^ self + ]. + + "/ check for directory ... + (self checkForProjectDirectoryFor:p) ifFalse:[ + ^ self + ]. + + "/ check for Make.proto ... + (self checkForMakeProtoFor:p) ifFalse:[ + ^ self + ]. + + "/ check for Makefile ... + (self checkForMakefileFor:p) ifFalse:[ + ^ self + ]. + + "/ now, execute the makefile found there ... + diagnosticFile := Filename newTemporary. + diagnostic := diagnosticFile writeStream. + error := false. + + [ + self withCursor:Cursor wait do:[ + OperatingSystem + executeCommand:'make' + inputFrom:nil + outputTo:diagnostic + errorTo:diagnostic + inDirectory:(p directory asFilename pathName) + onError:[error := true]. + ]. + + diagnostic close. + + textBox := TextBox new. + textBox initialText:(diagnosticFile readStream contents). + textBox title:'Make Diagnostic output:'. + textBox readOnly:true. + textBox noCancel. + textBox label:'Make Diagnostic output'. + textBox extent:(600@250); sizeFixed:true. + textBox showAtPointer. + + ] valueNowOrOnUnwindDo:[ + diagnosticFile delete + ]. + + +! + +buildLoadAllFile + "generate a loadAll file in the projects directory" + + |p | + + p := self currentProject. + p isNil ifTrue:[ + self information:'No project selected'. + ^ self + ]. + + self withCursor:Cursor wait do:[ + p createLoadAllFile. + ] +! + +buildMakefiles + "generate a Make.proto and Makefile in the projects directory" + + |p | + + p := self currentProject. + p isNil ifTrue:[ + self information:'No project selected'. + ^ self + ]. + + self withCursor:Cursor wait do:[ + p createProtoMakefile. + p createMakefile + ]. +! + +checkInAllClasses + "check in all classes" + + |p classes methods anyMethodMissing| + + p := self currentProject. + p isNil ifTrue:[ + self information:'No project selected'. + ^ self + ]. + + "/ check in classes ... + + classes := p classes. + classes do:[:aClass | + |clsName| + + aClass isBehavior ifFalse:[ + aClass isSymbol ifTrue:[ + clsName := aClass + ] ifFalse:[ + clsName := aClass className + ]. + Transcript showCR:('ProjectBrowser: cannot checkIn unloaded class: ' , clsName). + ] ifTrue:[ + aClass isLoaded ifFalse:[ + Transcript showCR:('ProjectBrowser: cannot checkIn unloaded class: ' , aClass name). + ] ifTrue:[ + aClass owningClass isNil ifTrue:[ "/ skip private classes + Transcript showCR:('ProjectBrowser: checking in class: ' , aClass name). + self checkInClass:aClass. + ] + ] + ] + ]. + + +! + +checkInMethods + "check in all extensions (patches)" + + |p methods anyMethodMissing| + + p := self currentProject. + p isNil ifTrue:[ + self information:'No project selected'. + ^ self + ]. + + "/ check methods ... + + anyMethodMissing := false. + methods := p methods. + methods size > 0 ifTrue:[ + methods do:[:aMethod | + aMethod isMethod ifFalse:[ + Transcript showCR:('ProjectBrowser: cannot checkIn unloaded method: ' , aMethod className , ' ' , aMethod methodName). + anyMethodMissing := true. + ] + ]. + anyMethodMissing ifTrue:[ + Transcript showCR:'ProjectBrowser: cannot save method patches & extensions due to missing method(s)'. + ] ifFalse:[ + Transcript showCR:('ProjectBrowser: checking in patches & extensions'). + self checkInMethods:methods + ]. + ]. + +! + +checkInProject + "check in all classes and extensions" + + |p| + + p := self currentProject. + p isNil ifTrue:[ + self information:'No project selected'. + ^ self + ]. + + "/ check in classes ... + self checkInAllClasses. + + "/ check methods ... + self checkInMethods. + + "/ check in the project file itself + self checkInProjectFile. + +! + +inspectCurrentProject + "inspect the current project" + + self hasProjectSelected ifTrue:[ + self currentProject inspect. + ] +! + +loadClassesFromDirectory + "load all classes as contained in the project into the system" + + self withReadCursorDo:[ + self currentProject loadClassesFromProjectDirectory. + ]. + +! + +makeCurrentProject + "make the selected Project the current project" + + |project| + + self hasProjectSelected ifTrue:[ + project := self currentProject. + + Project current:project. + self showWhat value == #current ifTrue:[ + self updateProjectTree + ] + ] +! + +moveMethodToProject + |p mthd newPackage| + + p := self currentProject. + + mthd := self selectedMethod. + mthd notNil ifTrue:[ + newPackage := Dialog request:'Move to project:'. + (newPackage size > 0 and:[newPackage ~= p package]) ifTrue:[ + mthd package:newPackage asSymbol. + p removeMethod:mthd. + self updatePatchesListForProject:p. + self projectTree remove:self selectedTreeNode. + ] + ]. +! + +newProject + self newProject:Project new. + +! + +newProject:newProject + |newNode| + + newNode := self nodeFor:newProject. + self addProjectNodeToTree:newNode. + self projectTreeHolder root:projectTree. +"/ self projectTreeHolder selectNode:newNode. +"/ self projectTreeHolder expand:newNode. + + self readAspectsFromProject. + newProject wasLoadedFromFile ifFalse:[ + self updateListOfRequiredPrerequisiteClasses. + ] +! + +newSubProject + |projectNode subProjectsNode newNode parentProject newProject| + + projectNode := self currentProjectNode. + + projectNode notNil ifTrue:[ + parentProject := projectNode contents. + subProjectsNode := projectNode children detect:[:child | child contents == #subprojects]. +self halt. + parentProject notNil ifTrue:[ + newProject := Project new. + newNode := self nodeFor:newProject. + + parentProject addSubProject:newProject. + subProjectsNode add:newNode. + self projectTreeHolder root:projectTree. + self projectTreeHolder selectNode:newNode. + ] + ] + +! + +openDocumentation + self openHTMLDocument: 'tools/pbrowser/TOP.html' + +! + +openProject + |fn| + + fn := Dialog + requestFileName:'filename:' + default:nil + ifFail:nil + pattern:'*.prj' + fromDirectory:(FileSelectionBox lastFileSelectionDirectory). + + fn notNil ifTrue:[ + self loadFromProjectFile:fn. + ] +! + +removeMethod + |p mthd| + + p := self currentProject. + + mthd := self selectedMethod. + mthd notNil ifTrue:[ + (self confirm:'Really remove the method (from both project and image) ?') ifTrue:[ + p removeMethod:mthd. + mthd who methodClass removeSelector:mthd who methodSelector. + self updatePatchesListForProject:p. + self projectTree remove:self selectedTreeNode. + ] + ]. +! + +removeMethodFromProject + |p mthd| + + p := self currentProject. + + mthd := self selectedMethod. + mthd notNil ifTrue:[ + (self confirm:'Really remove the method (from the project) ?') ifTrue:[ + mthd package:#unknown. + p removeMethod:mthd. + self updatePatchesListForProject:p. + self projectTree remove:self selectedTreeNode. + ] + ]. +! + +removeProject + |projectToRemove selectedNode subNode newNode parentNode parentProject newProject| + + self hasProjectNodeSelected ifTrue:[ + selectedNode := self selectedTreeNode. + projectToRemove := selectedNode contents. + + (self confirm:'Really remove the project ?') ifTrue:[ + self withExecuteCursorDo:[ + self projectTreeHolder removeSelection. + projectToRemove removeFromSystem. + ] + ] + ] +! + +renameProject + |nm projectNode selectedProject| + + projectNode := self currentProjectNode. + projectNode notNil ifTrue:[ + selectedProject := projectNode contents. + + nm := Dialog + request:'Rename to:' + initialAnswer:selectedProject name. + + nm size > 0 ifTrue:[ + selectedProject name:nm. +"/ selectedNode name:nm. +"/ selectedNode changed. + ] + ] +! + +saveProjectFile + "save the project file in the project directory" + + |d p| + + self modifiedChannel value ifTrue:[ + (self confirm:'Changes not confirmed; save anyway ?') ifFalse:[^ self] + ]. + + p := self currentProject. + p isNil ifTrue:[ + self information:'Select a project first.'. + ^self + ]. + p directory isNil ifTrue:[ + d := (Dialog request:'Project Directory:'). + d size == 0 ifTrue:[ + ^ self + ]. + p directory:d + ]. + + self withCursor:Cursor write do:[ + p saveAsProjectFile. + ] + + "Modified: / 26.4.1999 / 22:43:57 / cg" +! + +validateAgainstClassesInImage + "validate classes in project against classes found in the image" + + |project classesInProjectOnly classesInImageOnly bindings| + + project := self currentProject. + classesInImageOnly := IdentitySet new. + classesInProjectOnly := IdentitySet new. + + Smalltalk allClassesDo:[:aClass | + aClass isMeta ifFalse:[ + (aClass isNamespace not or:[aClass == Smalltalk]) ifTrue:[ + aClass package = project package ifTrue:[ + (project classInfoFor:aClass) isNil ifTrue:[ + classesInImageOnly add:aClass name. + ] + ] + ] + ] + ]. + project classInfo do:[:clsInfo | + |clsName cls| + + clsName := clsInfo className. + cls := Smalltalk at:clsName asSymbol. + (cls isBehavior not) ifTrue:[ + classesInProjectOnly add:clsName + ]. + ]. + + (classesInImageOnly isEmpty and:[classesInProjectOnly isEmpty]) ifTrue:[ + self information:'Set of classes in project and image are equal.'. + ^ self. + ]. + + classesInImageOnly := classesInImageOnly asOrderedCollection sort. + classesInProjectOnly := classesInProjectOnly asOrderedCollection sort. + + bindings := IdentityDictionary new. + bindings at:#classesInImageOnly put:classesInImageOnly. + bindings at:#classesInProjectOnly put:classesInProjectOnly. + + SimpleDialog + openDialogInterfaceSpec:(self class classValidationDialogSpec) + withBindings:bindings + + "Modified: / 26.9.1999 / 16:03:50 / cg" +! ! + !ProjectBrowser::ProjectTreeItem methodsFor:'accessing'! action