'From Squeak3.1alpha of 4 February 2001 [latest update: #3763] on 2 March 2001 at 11:07:44 pm'! "Change Set: ProjResources Date: 2 March 2001 Author: Andreas Raab Make large chunks of resource data independently available from the project."! Form subclass: #FormStub instanceVariableNames: 'locator ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! Notification subclass: #ProgressNotification instanceVariableNames: 'done amount extra ' classVariableNames: '' poolDictionaries: '' category: 'System-Exceptions Kernel'! Model subclass: #Project instanceVariableNames: 'world changeSet transcript parentProject previousProject displayDepth viewSize thumbnail nextProject guards projectParameters isolatedHead inForce version urlList environment lastDirectory lastSavedAtSeconds projectPreferenceFlagDictionary resourceManager ' classVariableNames: 'AllProjects CurrentProject GoalFreePercent GoalNotMoreThan UIProcess ' poolDictionaries: '' category: 'System-Support'! Object subclass: #ResourceCollector instanceVariableNames: 'stubMap originalMap locatorMap localDirectory baseUrl ' classVariableNames: 'Current ' poolDictionaries: '' category: 'System-Support'! !ResourceCollector commentStamp: 'ar 3/2/2001 23:06' prior: 0! The ResourceCollector collects resources that are encountered during project loading or publishing. It merely decouples the places where resources are held from the core object enumeration so that resources can be stored independently from what is enumerated for publishing.! Object subclass: #ResourceLocator instanceVariableNames: 'urlString fileSize localFileName ' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !ResourceLocator commentStamp: 'ar 3/2/2001 23:07' prior: 0! Describes where a resource can be found. Instance variables: urlString The URL of the resource fileSize The size of the resource localFileName When non-nil, the place where this resource was/is stored.! Object subclass: #ResourceManager instanceVariableNames: 'resourceMap loaded unloaded stopSemaphore stopFlag loaderProcess ' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !Object methodsFor: 'testing' stamp: 'ar 10/30/2000 23:22'! isForm ^false! ! !ArchiveMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'! close ! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'ar 3/2/2001 20:31'! addProgressDecoration: extraParam | f m | targetMorph ifNil:[^self]. (extraParam isKindOf: Form) ifTrue:[ targetMorph submorphsDo:[:mm| (mm isKindOf: SketchMorph) ifTrue:[mm delete]]. f _ Form extent: extraParam extent depth: extraParam depth. extraParam displayOn: f. m _ SketchMorph withForm: f. m align: m fullBounds leftCenter with: targetMorph fullBounds leftCenter + (2@0). targetMorph addMorph: m. ^self]. (extraParam isMemberOf: String) ifTrue:[ targetMorph submorphsDo:[:mm| (mm isKindOf: StringMorph) ifTrue:[mm delete]]. m _ StringMorph contents: extraParam. m align: m fullBounds bottomCenter + (0@8) with: targetMorph bounds bottomCenter. targetMorph addMorph: m. ^self].! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'ar 3/2/2001 20:25'! withProgressDo: aBlock | safetyFactor totals trialRect delta stageCompletedString | Smalltalk isMorphic ifFalse: [^aBlock value]. formerProject _ Project current. formerWorld _ World. formerProcess _ Processor activeProcess. targetMorph ifNil: [targetMorph _ ProgressTargetRequestNotification signal]. targetMorph ifNil: [ trialRect _ Rectangle center: Sensor cursorPoint extent: 80@80. delta _ trialRect amountToTranslateWithin: formerWorld bounds. trialRect _ trialRect translateBy: delta. translucentMorph _ TranslucentProgessMorph new opaqueBackgroundColor: Color white; bounds: trialRect; openInWorld: formerWorld. ] ifNotNil: [ translucentMorph _ TranslucentProgessMorph new setProperty: #morphicLayerNumber toValue: targetMorph morphicLayerNumber - 0.1; bounds: targetMorph boundsInWorld; openInWorld: targetMorph world. ]. stageCompleted _ 0. safetyFactor _ 1.1. "better to guess high than low" translucentMorph setProperty: #progressStageNumber toValue: 1. totals _ self loadingHistoryDataForKey: 'total'. newRatio _ 1.0. estimate _ totals size < 2 ifTrue: [ 15000 "be a pessimist" ] ifFalse: [ (totals sum - totals max) / (totals size - 1 max: 1) * safetyFactor. ]. start _ Time millisecondClockValue. self forkProgressWatcher. [ aBlock on: ProgressInitiationException do: [ :ex | ex sendNotificationsTo: [ :min :max :curr | "ignore this as it is inaccurate" ]. ]. ] on: ProgressNotification do: [ :note | note extraParam ifNotNil:[self addProgressDecoration: note extraParam]. stageCompletedString _ (note messageText findTokens: ' ') first. stageCompleted _ (stageCompletedString copyUpTo: $:) asNumber. cumulativeStageTime _ Time millisecondClockValue - start max: 1. prevData _ self loadingHistoryDataForKey: stageCompletedString. prevData isEmpty ifFalse: [ newRatio _ (cumulativeStageTime / (prevData average max: 1)) asFloat. ]. self loadingHistoryAt: stageCompletedString add: cumulativeStageTime. translucentMorph setProperty: #progressStageNumber toValue: stageCompleted + 1. note resume. ]. stageCompleted _ 999. "we may or may not get here" ! ! !DataStream methodsFor: 'other' stamp: 'ar 2/24/2001 22:45'! project ^nil! ! !FileDirectory methodsFor: 'file operations' stamp: 'ar 3/2/2001 16:15'! upLoadProject: projectFile named: destinationFileName resourceUrl: resUrl retry: aBool "Copy the contents of the existing fileStream into the file destinationFileName in this directory. fileStream can be anywhere in the fileSystem. No retrying for local file systems." ^ self putFile: projectFile named: destinationFileName ! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'ar 2/27/2001 22:23'! isTypeFile ^true! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'ar 2/27/2001 18:56'! realUrl "Senders expect url without trailing slash - #url returns slash" | url | url _ self url. url last = $/ ifTrue:[^url copyFrom: 1 to: url size-1]. ^url! ! !Form methodsFor: 'displaying' stamp: 'ar 3/2/2001 21:32'! displayScaledOn: aForm "Display the receiver on aForm, scaling if necessary. Form fromUser displayScaledOn: Display. " self extent = aForm extent ifTrue:[^self displayOn: aForm]. (WarpBlt current toForm: aForm) sourceForm: self destRect: aForm boundingBox; combinationRule: Form paint; cellSize: 2; warpBits.! ! !Form methodsFor: 'fileIn/Out' stamp: 'ar 2/24/2001 22:41'! comeFullyUpOnReload: smartRefStream bits isForm ifFalse:[^self]. "make sure the resource gets loaded afterwards" ResourceCollector current ifNil:[^self]. ResourceCollector current noteResource: bits replacing: self. ! ! !Form methodsFor: 'fileIn/Out' stamp: 'ar 2/24/2001 22:41'! objectForDataStream: refStream | prj repl | prj _ refStream project. prj ifNil:[^super objectForDataStream: refStream]. ResourceCollector current ifNil:[^super objectForDataStream: refStream]. repl _ ResourceCollector current objectForDataStream: refStream fromForm: self. "note: *must* force ourselves in out pointers if in IS or else won't get #comeFullyUpOnReload:" refStream replace: self with: repl. ^repl! ! !Form methodsFor: 'fileIn/Out' stamp: 'ar 2/24/2001 22:39'! replaceByResource: aForm "Replace the receiver by some resource that just got loaded" (self extent = aForm extent and:[self depth = aForm depth]) ifTrue:[ bits _ aForm bits. ].! ! !Form methodsFor: 'fileIn/Out' stamp: 'ar 2/26/2001 14:10'! unhibernate "If my bitmap has been compressed into a ByteArray, then expand it now, and return true." | resBits | bits isForm ifTrue:[ resBits _ bits. bits _ Bitmap new: self bitsSize. resBits displayScaledOn: self. ^true]. bits == nil ifTrue:[bits _ Bitmap new: self bitsSize. ^true]. (bits isMemberOf: ByteArray) ifTrue: [bits _ Bitmap decompressFromByteArray: bits. ^ true]. ^ false! ! !Form methodsFor: 'private' stamp: 'ar 10/30/2000 23:22'! setResourceBits: aForm "Private. Really. Used for setting the 'resource bits' when externalizing some form" bits _ aForm.! ! !Form methodsFor: 'testing' stamp: 'ar 10/30/2000 23:23'! isForm ^true! ! !Form methodsFor: 'resources' stamp: 'ar 3/2/2001 22:57'! readNativeResourceFrom: aStream | img | img _ [ImageReadWriter formFromStream: aStream] on: Error do:[:ex| ex return: nil]. img ifNil:[^nil]. "Forget color map if any" img _ Form extent: img extent depth: img depth bits: img bits. img displayInterpolatedOn: self. img _ nil.! ! !Form methodsFor: 'resources' stamp: 'ar 3/2/2001 20:45'! readResourceFrom: aStream "Store a resource representation of the receiver on aStream. Must be specific to the receiver so that no code is filed out." | bitsSize msb | (aStream next: 4) asString = self resourceTag ifFalse:[ aStream position: aStream position - 4. ^self readNativeResourceFrom: aStream]. width _ aStream nextNumber: 4. height _ aStream nextNumber: 4. depth _ aStream nextNumber: 4. bitsSize _ aStream nextNumber: 4. bitsSize = 0 ifFalse:[ bits _ aStream next: bitsSize. ^self]. msb _ (aStream nextNumber: 4) = 1. bitsSize _ aStream nextNumber: 4. bits _ Bitmap new: self bitsSize. (Form extent: width@height depth: depth bits: (aStream next: bitsSize * 4)) displayOn: self. msb = Smalltalk isBigEndian ifFalse:[ bits swapBytesFrom: 1 to: bits size. ].! ! !Form methodsFor: 'resources' stamp: 'ar 2/27/2001 14:56'! resourceTag ^'FORM'! ! !Form methodsFor: 'resources' stamp: 'ar 2/27/2001 15:07'! storeResourceOn: aStream "Store a resource representation of the receiver on aStream. Must be specific to the receiver so that no code is filed out." self hibernate. aStream nextPutAll: self resourceTag asByteArray. "tag" aStream nextNumber: 4 put: width. aStream nextNumber: 4 put: height. aStream nextNumber: 4 put: depth. (bits isMemberOf: ByteArray) ifFalse:[ "must store bitmap" aStream nextNumber: 4 put: 0. "tag" aStream nextNumber: 4 put: (Smalltalk endianness == #big ifTrue:[1] ifFalse:[0]). ]. aStream nextNumber: 4 put: bits size. aStream nextPutAll: bits. ! ! !FormStub methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:02'! locator ^locator! ! !FormStub methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:02'! locator: aString locator _ aString! ! !FormStub methodsFor: 'fileIn/Out' stamp: 'ar 2/27/2001 21:36'! objectForDataStream: refStream "Force me into outPointers so that I get notified about startup" refStream replace: self with: self. ^self! ! !HTTPRequest methodsFor: 'testing' stamp: 'ar 3/2/2001 16:53'! isSemaphoreSignaled "Return true if the associated semaphore is currently signaled. This information can be used to determine whether the download has finished given that there is no other process waiting on the semaphore." ^semaphore isSignaled! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'ar 2/22/2001 10:45'! writeForExportWithSources: fName inDirectory: aDirectory changeSet: aChangeSetOrNil "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." "An experimental version to fileout a changeSet first so that a project can contain its own classes" | fileStream temp tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource | state = #activeCopy ifFalse: [self error: 'wrong state']. (fName includes: $.) ifFalse: [ ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. temp _ endMarker. endMarker _ nil. tempFileName _ aDirectory nextNameFor: 'SqProject' extension: 'temp'. zipper _ [ Preferences debugPrintSpaceLog ifTrue:[ fileStream _ aDirectory newFileNamed: (fName copyFrom: 1 to: (fName lastIndexOf: $.)), 'space'. self printSpaceAnalysisOn: fileStream. fileStream close]. ProgressNotification signal: '3:uncompressedSaveComplete'. (aDirectory oldFileNamed: tempFileName) compressFile. "makes xxx.gz" aDirectory rename: (tempFileName, FileDirectory dot, 'gz') toBe: fName. aDirectory deleteFileNamed: tempFileName ifAbsent: [] ]. fileStream _ aDirectory newFileNamed: tempFileName. fileStream fileOutChangeSet: aChangeSetOrNil andObject: self. "remember extra structures. Note class names." endMarker _ temp. "append sources" allClassesInRoots _ arrayOfRoots select: [:cls | cls isKindOf: Behavior]. classesToWriteEntirely _ allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. methodsWithSource _ OrderedCollection new. allClassesInRoots do: [ :cls | (classesToWriteEntirely includes: cls) ifFalse: [ cls selectorsAndMethodsDo: [ :sel :meth | meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. ]. ]. ]. (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self]. fileStream reopen; setToEnd. fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. methodsWithSource do: [ :each | fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', each first name printString,' methodsFor: ', (each first organization categoryOfElement: each second) asString printString, ' stamp: ',(Utilities timeStampForMethod: each third) printString; cr. fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. fileStream nextChunkPut: ' '; cr. ]. classesToWriteEntirely do: [:cls | cls isMeta ifFalse: [fileStream nextPutAll: (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. cls organization putCommentOnFile: fileStream numbered: 0 moveSource: false forClass: cls. "does nothing if metaclass" cls organization categories do: [:heading | cls fileOutCategory: heading on: fileStream moveSource: false toFile: 0]]. "no class initialization -- it came in as a real object" fileStream close. zipper value. ! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:11'! amount ^amount! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! amount: aNumber amount _ aNumber! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:11'! done ^done! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! done: aNumber done _ aNumber! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! extraParam ^extra! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! extraParam: anObject extra _ anObject! ! !ProgressNotification class methodsFor: 'exceptionInstantiator' stamp: 'ar 3/2/2001 20:11'! signal: signalerText extra: extraParam "TFEI - Signal the occurrence of an exceptional condition with a specified textual description." | ex | ex := self new. ex initialContext: thisContext sender. ex extraParam: extraParam. ^ex signal: signalerText! ! !Project methodsFor: 'menu messages' stamp: 'ar 3/2/2001 17:25'! enter: returningFlag revert: revertFlag saveForRevert: saveForRevert "Install my ChangeSet, Transcript, and scheduled views as current globals. If returningFlag is true, we will return to the project from whence the current project was entered; don't change its previousProject link in this case. If saveForRevert is true, save the ImageSegment of the project being left. If revertFlag is true, make stubs for the world of the project being left. If revertWithoutAsking is true in the project being left, then always revert." | showZoom recorderOrNil old forceRevert response seg newProcess | (world isKindOf: StringMorph) ifTrue: [ self inform: 'This project is not all here. I will try to load a complete version.'. ^self loadFromServer: true "try to get a fresh copy" ]. self isCurrentProject ifTrue: [^ self]. "Check the guards" guards ifNotNil: [guards _ guards reject: [:obj | obj isNil]. guards do: [:obj | obj okayToEnterProject ifFalse: [^ self]]]. forceRevert _ false. CurrentProject rawParameters ifNil: [revertFlag ifTrue: [^ self inform: 'nothing to revert to']] ifNotNil: [saveForRevert ifFalse: [ forceRevert _ CurrentProject projectParameters at: #revertWithoutAsking ifAbsent: [false]]]. forceRevert not & revertFlag ifTrue: [ response _ SelectionMenu confirm: 'Are you sure you want to destroy this Project\ and revert to an older version?\\(From the parent project, click on this project''s thumbnail.)' withCRs trueChoice: 'Revert to saved version' falseChoice: 'Cancel'. response ifFalse: [^ self]]. revertFlag | forceRevert ifTrue: [seg _ CurrentProject projectParameters at: #revertToMe ifAbsent: [ ^ self inform: 'nothing to revert to']] ifFalse: [ CurrentProject finalExitActions. CurrentProject makeThumbnail. returningFlag == #specialReturn ifTrue: [ ProjectHistory forget: CurrentProject. "this guy is irrelevant" Project forget: CurrentProject. ] ifFalse: [ ProjectHistory remember: CurrentProject. ]. ]. (revertFlag | saveForRevert | forceRevert) ifFalse: [ (Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [ self storeToMakeRoom]]. CurrentProject abortResourceLoading. Smalltalk isMorphic ifTrue: [Display bestGuessOfCurrentWorld triggerClosingScripts]. "Update the display depth and make a thumbnail of the current project" CurrentProject displayDepth: Display depth. old _ CurrentProject. "for later" "Show the project transition. Note: The project zoom is run in the context of the old project, so that eventual errors can be handled accordingly" displayDepth == nil ifTrue: [displayDepth _ Display depth]. self installNewDisplay: Display extent depth: displayDepth. (showZoom _ self showZoom) ifTrue: [ self displayZoom: CurrentProject parent ~~ self]. (world isMorph and: [world hasProperty: #letTheMusicPlay]) ifTrue: [world removeProperty: #letTheMusicPlay] ifFalse: [Smalltalk at: #ScorePlayer ifPresent: [:playerClass | playerClass allSubInstancesDo: [:player | player pause]]]. returningFlag == #specialReturn ifTrue: [ old removeChangeSetIfPossible. "keep this stuff from accumulating" nextProject _ nil ] ifFalse: [ returningFlag ifTrue: [nextProject _ CurrentProject] ifFalse: [previousProject _ CurrentProject]. ]. CurrentProject saveState. CurrentProject isolationHead == self isolationHead ifFalse: [self invokeFrom: CurrentProject]. CurrentProject _ self. Smalltalk newChanges: changeSet. TranscriptStream newTranscript: transcript. Sensor flushKeyboard. Smalltalk isMorphic ifTrue: [recorderOrNil _ Display pauseMorphicEventRecorder]. ProjectHistory remember: CurrentProject. world isMorph ifTrue: [Display changeMorphicWorldTo: world. "Signifies Morphic" world install. world transferRemoteServerFrom: old world. "(revertFlag | saveForRevert | forceRevert) ifFalse: [ (Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [ self storeSomeSegment]]." recorderOrNil ifNotNil: [recorderOrNil resumeIn: world]. world triggerOpeningScripts] ifFalse: [Display changeMorphicWorldTo: nil. "Signifies MVC" Smalltalk at: #ScheduledControllers put: world]. saveForRevert ifTrue: [ Smalltalk garbageCollect. "let go of pointers" old storeSegment. "result _" old world isInMemory ifTrue: ['Can''t seem to write the project.'] ifFalse: [old projectParameters at: #revertToMe put: old world xxxSegment clone]. 'Project written.']. "original is for coming back in and continuing." revertFlag | forceRevert ifTrue: [ seg clone revert]. "non-cloned one is for reverting again later" self removeParameter: #exportState. "Complete the enter: by launching a new process" world isMorph ifTrue: [ self finalEnterActions. world repairEmbeddedWorlds. Project spawnNewProcessAndTerminateOld: true ] ifFalse: [ SystemWindow clearTopWindow. "break external ref to this project" newProcess _ [ ScheduledControllers resetActiveController. "in case of walkback in #restore" showZoom ifFalse: [ScheduledControllers restore]. ScheduledControllers searchForActiveController ] fixTemps newProcess priority: Processor userSchedulingPriority. newProcess resume. "lose the current process and its referenced morphs" Processor terminateActive. ]! ! !Project methodsFor: 'menu messages' stamp: 'ar 3/2/2001 17:27'! finalEnterActions | navigator armsLengthCmd navType thingsToUnhibernate | thingsToUnhibernate _ world valueOfProperty: #thingsToUnhibernate ifAbsent: [#()]. thingsToUnhibernate do: [ :each | each unhibernate]. world removeProperty: #thingsToUnhibernate. navType _ ProjectNavigationMorph preferredNavigator. armsLengthCmd _ self parameterAt: #armsLengthCmd ifAbsent: [nil]. navigator _ world findA: navType. Preferences showProjectNavigator & navigator isNil ifTrue: [ (navigator _ navType new) bottomLeft: world bottomLeft; openInWorld: world. ]. navigator notNil & armsLengthCmd notNil ifTrue: [ navigator color: Color lightBlue ]. armsLengthCmd notNil ifTrue: [ Preferences showFlapsWhenPublishing ifFalse:[self flapsSuppressed: true. navigator ifNotNil:[navigator visible: false]]. armsLengthCmd openInWorld: world ]. self startResourceLoading.! ! !Project methodsFor: 'file in/out' stamp: 'ar 3/2/2001 19:02'! compressFilesIn: tempDir to: localName in: localDirectory resources: collector "Compress all the files in tempDir making up a zip file in localDirectory named localName" | archive entry urlMap archiveName | urlMap _ Dictionary new. collector locatorsDo:[:loc| "map local file names to urls" urlMap at: (tempDir localNameFor: loc localFileName) put: loc urlString]. archive _ ZipArchive new. tempDir fileNames do:[:fn| archiveName _ urlMap at: fn ifAbsent:[fn]. entry _ archive addFile: (tempDir fullNameFor: fn) as: archiveName. entry desiredCompressionMethod: ZipArchive compressionStored. ]. archive writeToFileNamed: (localDirectory fullNameFor: localName). archive close. tempDir fileNames do:[:fn| tempDir deleteFileNamed: fn ifAbsent:[]]. localDirectory deleteDirectory: tempDir localName.! ! !Project methodsFor: 'file in/out' stamp: 'ar 3/2/2001 20:28'! exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory "Store my project out on the disk as an *exported* ImageSegment. All outPointers will be in a form that can be resolved in the target image. Name it .extSeg. What do we do about subProjects, especially if they are out as local image segments? Force them to come in? Player classes are included automatically." | is str ans revertSeg roots holder collector fd mgr | "An experimental version to fileout a changeSet first so that a project can contain its own classes" world isMorph ifFalse: [ self projectParameters at: #isMVC put: true. ^ false]. "Only Morphic projects for now" world ifNil: [^ false]. world presenter ifNil: [^ false]. Utilities emptyScrapsBook. world currentHand pasteBuffer: nil. "don't write the paste buffer." world currentHand mouseOverHandler initialize. "forget about any references here" "Display checkCurrentHandForObjectToPaste." Command initialize. world clearCommandHistory. world fullReleaseCachedState; releaseViewers. world cleanseStepList. world localFlapTabs size = world flapTabs size ifFalse: [ self error: 'Still holding onto Global flaps']. world releaseSqueakPages. ScriptEditorMorph writingUniversalTiles: (self projectParameterAt: #universalTiles ifAbsent: [false]). holder _ Project allProjects. "force them in to outPointers, where DiskProxys are made" "Just export me, not my previous version" revertSeg _ self projectParameters at: #revertToMe ifAbsent: [nil]. self projectParameters removeKey: #revertToMe ifAbsent: []. roots _ OrderedCollection new. roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail. roots add: world activeHand. "; addAll: classList; addAll: (classList collect: [:cls | cls class])" roots _ roots reject: [ :x | x isNil]. "early saves may not have active hand or thumbnail" fd _ aDirectory directoryNamed: self resourceDirectoryName. fd assureExistance. "Clean up resource references before writing out" mgr _ self resourceManager. self resourceManager: nil. ResourceCollector current: ResourceCollector new. ResourceCollector current localDirectory: fd. ResourceCollector current baseUrl: self resourceUrl. ResourceCollector current initializeFrom: mgr. ProgressNotification signal: '2:findingResources' extra: '(collecting resources...)'. is _ ImageSegment new copySmartRootsExport: roots asArray. "old way was (is _ ImageSegment new copyFromRootsForExport: roots asArray)" self resourceManager: mgr. collector _ ResourceCollector current. ResourceCollector current: nil. ProgressNotification signal: '2:foundResources' extra: ''. is state = #tooBig ifTrue: [ collector replaceAll. ^ false]. str _ ''. "considered legal to save a project that has never been entered" (is outPointers includes: world) ifTrue: [ str _ str, '\Project''s own world is not in the segment.' withCRs]. str isEmpty ifFalse: [ ans _ (PopUpMenu labels: 'Do not write file Write file anyway Debug') startUpWithCaption: str. ans = 1 ifTrue: [ revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg]. collector replaceAll. ^ false]. ans = 3 ifTrue: [ collector replaceAll. self halt: 'Segment not written']]. is writeForExportWithSources: aFileName inDirectory: fd changeSet: aChangeSetOrNil. SecurityManager default signFile: aFileName directory: fd. "Compress all files and update check sums" collector forgetObsolete. self storeResourceList: collector in: fd. self compressFilesIn: fd to: aFileName in: aDirectory resources: collector. "Now update everything that we know about" mgr updateResourcesFrom: collector. revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg]. holder. collector replaceAll. world flapTabs do: [:ft | (ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]]. is arrayOfRoots do: [:obj | obj class == ScriptEditorMorph ifTrue: [obj unhibernate]]. ^ true ! ! !Project methodsFor: 'file in/out' stamp: 'ar 2/27/2001 13:44'! projectExtension ^self class projectExtension! ! !Project methodsFor: 'file in/out' stamp: 'ar 2/27/2001 14:10'! storeOnServerInnards "Save to disk as an Export Segment. Then put that file on the server I came from, as a new version. Version is literal piece of file name. Mime encoded and http encoded." | servers resp newName primaryServerDirectory serverVersionPair localDirectory localVersionPair myVersionNumber warning maxNumber | self assureIntegerVersion. "Find out what version" (servers _ self serverList) ifNil: [ (primaryServerDirectory _ self findAFolderToStoreProjectIn) ifNotNil: [ servers _ Array with: primaryServerDirectory. self storeNewPrimaryURL: primaryServerDirectory realUrl, '/'. ]. ] ifNotNil: [ primaryServerDirectory _ servers first. ]. localDirectory _ self squeakletDirectory. serverVersionPair _ self class mostRecent: self name onServer: primaryServerDirectory. localVersionPair _ self class mostRecent: self name onServer: localDirectory. maxNumber _ myVersionNumber _ self currentVersionNumber. ProgressNotification signal: '2:versionsDetected'. warning _ ''. myVersionNumber < serverVersionPair second ifTrue: [ warning _ warning,'\There are newer version(s) on the server'. maxNumber _ maxNumber max: serverVersionPair second. ]. myVersionNumber < localVersionPair second ifTrue: [ warning _ warning,'\There are newer version(s) in the local directory'. maxNumber _ maxNumber max: localVersionPair second. ]. "8 Nov 2000 - only check on the first attempt to publish" myVersionNumber = 0 ifTrue: [ warning isEmpty ifFalse: [ myVersionNumber = 0 ifTrue: [ warning _ warning,'\THIS PROJECT HAS NEVER BEEN SAVED' ]. warning _ 'WARNING', '\Project: ',self name,warning. resp _ (PopUpMenu labels: 'Store anyway\Cancel' withCRs) startUpWithCaption: (warning, '\Please cancel, rename this project, and see what is there.') withCRs. resp ~= 1 ifTrue: [^ nil] ]. ]. version _ self bumpVersion: maxNumber. "write locally - now zipped automatically" newName _ self versionedFileName. lastSavedAtSeconds _ Time totalSeconds. self exportSegmentFileName: newName directory: localDirectory. ProgressNotification signal: '4:localSaveComplete'. "3 is deep in export logic" primaryServerDirectory ifNotNil: [ self writeFileNamed: newName fromDirectory: localDirectory toServer: primaryServerDirectory. ]. ProgressNotification signal: '9999 save complete'. "Later, store with same name on secondary servers. Still can be race conditions. All machines will go through the server list in the same order." "2 to: servers size do: [:aServer | aServer putFile: local named: newName]." ! ! !Project methodsFor: 'file in/out' stamp: 'ar 3/2/2001 19:23'! writeFileNamed: localFileName fromDirectory: localDirectory toServer: primaryServerDirectory | local resp gifFileName f | local _ localDirectory oldFileNamed: localFileName. resp _ primaryServerDirectory upLoadProject: local named: localFileName resourceUrl: self resourceUrl retry: false. local close. resp == true ifFalse: [ "abandon resources that would've been stored with the project" self resourceManager abandonResourcesThat: [:loc| loc urlString beginsWith: self resourceUrl]. self inform: 'the primary server of this project seems to be down (', resp printString,')'. ^ self ]. gifFileName _ self name,'.gif'. localDirectory deleteFileNamed: gifFileName ifAbsent: []. local _ localDirectory fileNamed: gifFileName. thumbnail ifNil: [ (thumbnail _ Form extent: 100@80) fillColor: Color orange ] ifNotNil: [ thumbnail unhibernate. ]. f _ thumbnail colorReduced. "minimize depth" f depth > 8 ifTrue: [ f _ thumbnail asFormOfDepth: 8 ]. GIFReadWriter putForm: f onStream: local. local close. local _ localDirectory oldFileNamed: gifFileName. resp _ primaryServerDirectory putFile: local named: gifFileName retry: false. local close. primaryServerDirectory updateProjectInfoFor: self. primaryServerDirectory sleep. "if ftp, close the connection" ! ! !Project methodsFor: 'resources' stamp: 'ar 3/2/2001 17:25'! abortResourceLoading "Abort loading resources" resourceManager ifNil:[^self]. resourceManager stopDownload.! ! !Project methodsFor: 'resources' stamp: 'ar 3/2/2001 21:36'! resourceDirectoryName "Project current resourceDirectoryName" | v | ^String streamContents:[:s| s nextPutAll: self name. s nextPutAll: FileDirectory dot. v _ self currentVersionNumber printString. v size < 3 ifTrue:[v _ '0', v]. v size < 3 ifTrue:[v _ '0', v]. s nextPutAll: v. ] ! ! !Project methodsFor: 'resources' stamp: 'ar 2/27/2001 17:02'! resourceManager ^resourceManager ifNil:[resourceManager _ ResourceManager new]! ! !Project methodsFor: 'resources' stamp: 'ar 2/27/2001 15:49'! resourceManager: aResourceManager resourceManager _ aResourceManager! ! !Project methodsFor: 'resources' stamp: 'ar 3/2/2001 21:36'! resourceUrl "compose my base url for resources on the server" | firstURL | urlList isEmptyOrNil ifTrue: [^'']. firstURL _ urlList first. firstURL last == $/ ifFalse: [firstURL _ firstURL, '/']. ^ firstURL, self resourceDirectoryName ! ! !Project methodsFor: 'resources' stamp: 'ar 3/2/2001 17:26'! startResourceLoading "Abort loading resources" resourceManager ifNil:[^self]. resourceManager startDownload.! ! !Project methodsFor: 'resources' stamp: 'ar 3/2/2001 15:16'! storeResourceList: collector in: fd "Store a list of all used resources in the given directory. Used for maintenance." | file rcName | rcName _ self resourceDirectoryName,'.rc'. file _ fd forceNewFileNamed: rcName. collector locatorsDo:[:loc| file nextPutAll: loc urlString; cr]. file close. file _ fd readOnlyFileNamed: rcName. file compressFile. fd deleteFileNamed: rcName ifAbsent:[].! ! !Project class methodsFor: 'squeaklet on server' stamp: 'ar 2/27/2001 13:43'! projectExtension ^'pr'! ! !ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'ar 2/27/2001 20:09'! openName: aFileName stream: preStream fromDirectory: aDirectoryOrNil withProjectView: existingView "Reconstitute a Morph from the selected file, presumed to be represent a Morph saved via the SmartRefStream mechanism, and open it in an appropriate Morphic world." | morphOrList proj trusted localDir projStream archive mgr | (preStream isNil or: [preStream size = 0]) ifTrue: [ ProgressNotification signal: '9999 about to enter project'. "the hard part is over" ^self inform: 'It looks like a problem occurred while getting this project. It may be temporary, so you may want to try again,' ]. ProgressNotification signal: '2:fileSizeDetermined ',preStream size printString. preStream isZipArchive ifTrue:[ archive _ ZipArchive new readFrom: preStream. projStream _ self projectStreamFromArchive: archive] ifFalse:[projStream _ preStream]. trusted _ SecurityManager default positionToSecureContentsOf: projStream. trusted ifFalse:[(SecurityManager default enterRestrictedMode) ifFalse:[ (preStream respondsTo: #close) ifTrue:[preStream close]. ^self]]. localDir _ Project squeakletDirectory. aFileName ifNotNil: [ (aDirectoryOrNil isNil or: [aDirectoryOrNil pathName ~= localDir pathName]) ifTrue: [ localDir deleteFileNamed: aFileName. (localDir fileNamed: aFileName) nextPutAll: preStream allContentsWithoutSideEffects; close. ]. ]. morphOrList _ projStream asUnZippedStream. preStream sleep. "if ftp, let the connection close" ProgressNotification signal: '3:unzipped'. ResourceCollector current: ResourceCollector new. morphOrList _ morphOrList fileInObjectAndCode. mgr _ ResourceManager new initializeFrom: ResourceCollector current. archive ifNotNil:[mgr preLoadFromArchive: archive]. (preStream respondsTo: #close) ifTrue:[preStream close]. ResourceCollector current: nil. ProgressNotification signal: '4:filedIn'. ProgressNotification signal: '9999 about to enter project'. "the hard part is over" (morphOrList isKindOf: ImageSegment) ifTrue: [ proj _ morphOrList arrayOfRoots detect: [:mm | mm class == Project] ifNone: [^self inform: 'No project found in this file']. proj resourceManager: mgr. proj versionFrom: preStream. proj lastDirectory: aDirectoryOrNil. CurrentProjectRefactoring currentBeParentTo: proj. existingView ifNil: [ Smalltalk isMorphic ifTrue: [ proj createViewIfAppropriate. ] ifFalse: [ ProjectView openAndEnter: proj. "Note: in MVC we get no further than the above" ]. ] ifNotNil: [ (existingView project isKindOf: DiskProxy) ifFalse: [ existingView project changeSet name: ChangeSet defaultName ]. "proj changeSet name: otherProjectName." "<<< why would we need this?" (existingView owner isKindOf: SystemWindow) ifTrue: [ existingView owner model: proj ]. existingView project: proj. ]. ^ ProjectEntryNotification signal: proj ]. (morphOrList isKindOf: SqueakPage) ifTrue: [ morphOrList _ morphOrList contentsMorph ]. (morphOrList isKindOf: PasteUpMorph) ifFalse: [ ^ self inform: 'This is not a PasteUpMorph or exported Project.' ]. (Project newMorphicOn: morphOrList) enter ! ! !ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'ar 2/27/2001 14:33'! projectStreamFromArchive: archive | ext prFiles entry unzipped | ext _ FileDirectory dot, Project projectExtension. prFiles _ archive members select:[:any| any fileName endsWith: ext]. prFiles isEmpty ifTrue:[^'']. entry _ prFiles first. unzipped _ RWBinaryOrTextStream on: (ByteArray new: entry uncompressedSize). entry extractTo: unzipped. ^unzipped reset! ! !ReadWriteStream methodsFor: 'testing' stamp: 'ar 2/27/2001 13:38'! isZipArchive "Determine if this appears to be a valid Zip archive" | sig | self binary. sig _ (self next: 4) asString. self position: self position - 4. "rewind" ^(ZipArchive validSignatures includes: sig)! ! !ResourceCollector methodsFor: 'initialize' stamp: 'ar 2/27/2001 23:08'! forgetObsolete "Forget obsolete locators, e.g., those that haven't been referenced and not been stored on a file." locatorMap keys "copy" do:[:k| (locatorMap at: k) localFileName ifNil:[locatorMap removeKey: k]].! ! !ResourceCollector methodsFor: 'initialize' stamp: 'ar 2/27/2001 20:08'! initialize originalMap _ IdentityDictionary new. stubMap _ IdentityDictionary new. locatorMap _ IdentityDictionary new.! ! !ResourceCollector methodsFor: 'initialize' stamp: 'ar 2/27/2001 22:36'! initializeFrom: aResourceManager "Initialize the receiver from aResourceManager." aResourceManager resourceMap keysAndValuesDo:[:loc :res| (res notNil) ifTrue:[locatorMap at: res put: loc. loc localFileName: nil]. ].! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:32'! baseUrl ^baseUrl! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:39'! baseUrl: aString baseUrl _ aString. baseUrl isEmpty ifFalse:[ baseUrl last = $/ ifFalse:[baseUrl _ baseUrl copyWith: $/]. ].! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:23'! localDirectory ^localDirectory! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:24'! localDirectory: aDirectory localDirectory _ aDirectory! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 22:54'! locators ^locatorMap values! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:07'! locatorsDo: aBlock ^locatorMap valuesDo: aBlock! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 17:01'! noteResource: aResourceStub replacing: anObject "Remember the fact that we need to load aResource which will replace anObject." stubMap at: aResourceStub put: anObject.! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! objectForDataStream: refStream fromForm: aForm "Return a replacement for aForm to be stored instead" | stub fName fStream copy loc fullSize | stub _ originalMap at: aForm ifAbsent:[nil]. stub ifNotNil:[^aForm]. (aForm width <= 32 and:[aForm height <= 32 and:[aForm depth <= 8]]) ifTrue:[^aForm]. "too small to be of interest" stub _ FormStub extent: (aForm width min: 32) @ (aForm height min: 32) depth: (aForm depth min: 8). aForm displayScaledOn: stub. aForm hibernate. copy _ Form extent: aForm extent depth: aForm depth bits: nil. copy setResourceBits: aForm bits. fName _ localDirectory nextNameFor:'resource' extension:'form'. fStream _ localDirectory newFileNamed: fName. fStream binary. copy storeResourceOn: fStream. "Compress contents here" fStream position: 0. fStream compressFile. localDirectory deleteFileNamed: fName. localDirectory rename: fName, FileDirectory dot, 'gz' toBe: fName. fStream _ localDirectory readOnlyFileNamed: fName. fullSize _ fStream size. fStream close. ProgressNotification signal: '2:resourceFound' extra: stub. stub hibernate. loc _ locatorMap at: aForm ifAbsent:[nil]. (loc notNil and:[loc hasRemoteContents not]) ifTrue:[ "The locator describes some local resource. If we're preparing to upload the entire project to a remote server, make it a remote URL instead." baseUrl asUrl hasRemoteContents ifTrue:[loc urlString: baseUrl, fName]]. loc ifNil:[ loc _ ResourceLocator new urlString: baseUrl, fName. locatorMap at: aForm put: loc]. loc localFileName: (localDirectory fullNameFor: fName). loc resourceFileSize: fullSize. stub locator: loc. aForm setResourceBits: stub. originalMap at: aForm put: copy. stubMap at: stub put: aForm. locatorMap at: aForm put: loc. ^aForm! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 22:59'! removeLocator: loc locatorMap keys "copy" do:[:k| (locatorMap at: k) = loc ifTrue:[locatorMap removeKey: k]].! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:21'! replaceAll "Replace all resources by their originals. Done after the resource have been collected to get back to the original state." originalMap keysAndValuesDo:[:k :v| v ifNotNil:[k replaceByResource: v]. ].! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:08'! resourceFileNames "Return a list of all the resource files created" ^locatorMap values asArray collect:[:loc| loc localFileName].! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 17:01'! stubMap ^stubMap! ! !ResourceCollector methodsFor: 'objects from disk' stamp: 'ar 2/24/2001 22:37'! objectForDataStream: refStream "This should never happen; when projects get written they must be decoupled from the resource collector. If you get the error message below something is seriously broken." self error:'Cannot write resource manager'! ! !ResourceCollector class methodsFor: 'instance creation' stamp: 'ar 2/24/2001 22:44'! new ^super new initialize! ! !ResourceCollector class methodsFor: 'accessing' stamp: 'ar 2/24/2001 21:41'! current ^Current! ! !ResourceCollector class methodsFor: 'accessing' stamp: 'ar 2/24/2001 21:41'! current: aResourceManager Current _ aResourceManager! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:00'! localFileName ^localFileName! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:01'! localFileName: aString localFileName _ aString! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 3/2/2001 18:13'! resourceFileSize ^fileSize! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 3/2/2001 18:13'! resourceFileSize: aNumber fileSize _ aNumber! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 19:57'! urlString ^urlString! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 19:57'! urlString: aString urlString _ aString.! ! !ResourceLocator methodsFor: 'testing' stamp: 'ar 2/27/2001 22:11'! hasRemoteContents "Return true if we describe a resource which is non-local, e.g., on some remote server." (urlString indexOf: $:) = 0 ifTrue:[^false]. "no scheme" ^urlString asUrl hasRemoteContents! ! !ResourceLocator methodsFor: 'printing' stamp: 'ar 2/27/2001 20:02'! printOn: aStream super printOn: aStream. aStream nextPut: $(; print: urlString; nextPut: $)! ! !ResourceLocator methodsFor: 'comparing' stamp: 'ar 2/27/2001 20:02'! = aLocator self urlString = aLocator urlString ifFalse:[^false]. ^true! ! !ResourceLocator methodsFor: 'comparing' stamp: 'ar 2/27/2001 20:02'! hash ^urlString hash! ! !ResourceManager methodsFor: 'initialize' stamp: 'ar 2/27/2001 16:54'! initialize "So resources may get garbage collected if possible" self reset.! ! !ResourceManager methodsFor: 'initialize' stamp: 'ar 2/27/2001 20:11'! initializeFrom: aCollector "Initialize the receiver from the given resource collector. None of the resources have been loaded yet, so make register all resources as unloaded." | newLoc | aCollector stubMap keysAndValuesDo:[:stub :res| newLoc _ stub locator. resourceMap at: newLoc put: res. unloaded add: newLoc. ].! ! !ResourceManager methodsFor: 'initialize' stamp: 'ar 2/27/2001 16:54'! reset "Clean out everything" resourceMap _ WeakValueDictionary new. loaded _ Set new. unloaded _ Set new.! ! !ResourceManager methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:50'! addResource: anObject locator: aLocator resourceMap at: aLocator put: anObject. loaded add: aLocator.! ! !ResourceManager methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:56'! addResource: anObject url: urlString ^self addResource: anObject locator: (ResourceLocator new urlString: urlString)! ! !ResourceManager methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:57'! resourceMap ^resourceMap! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 17:14'! installResource: aResource from: aStream aResource ifNil:[^self]. "it went away, so somebody might have deleted it" ! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 21:15'! installResource: aResource from: aStream locator: loc | repl | aResource ifNil:[^self]. "it went away, so somebody might have deleted it" (aStream == nil or:[aStream size = 0]) ifTrue:[^self]. "error?!!" repl _ aResource clone readResourceFrom: aStream asUnZippedStream. repl ifNotNil:[ aResource replaceByResource: repl. unloaded remove: loc. loaded add: loc. ].! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 20:35'! loaderProcess | loader requests req locator resource | loader _ HTTPLoader default. requests _ Dictionary new. self prioritizedUnloadedResources do:[:loc| req _ HTTPLoader httpRequestClass for: (self hackURL: loc urlString) in: loader. loader addRequest: req. requests at: req put: loc]. [stopFlag or:[requests isEmpty]] whileFalse:[ stopSemaphore waitTimeoutMSecs: 500. requests keys "need a copy" do:[:r| r isSemaphoreSignaled ifTrue:[ locator _ requests at: r. requests removeKey: r. resource _ resourceMap at: locator ifAbsent:[nil]. self installResource: resource from: r contentStream locator: locator. (resource isKindOf: Form) ifTrue:[ WorldState addDeferredUIMessage: self formChangedReminder]. ]. ]. ]. "Either done downloading or terminating process" stopFlag ifTrue:[loader abort]. loaderProcess _ nil. stopSemaphore _ nil.! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 17:16'! preLoadFromArchive: aZipArchive "Load the resources from the given zip archive" | orig nameMap resMap loc | resMap _ Dictionary new. nameMap _ Dictionary new. unloaded do:[:locator| locator localFileName: nil. nameMap at: locator urlString put: locator. resMap at: locator urlString put: (resourceMap at: locator)]. aZipArchive members do:[:entry| orig _ resMap at: entry fileName ifAbsent:[nil]. loc _ nameMap at: entry fileName ifAbsent:[nil]. self installResource: orig from: entry contentStream locator: loc. ].! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 18:16'! prioritizedUnloadedResources "Return an array of unloaded resource locators prioritized by some means" | list | list _ unloaded asArray. ^list sort:[:l1 :l2| (l1 resourceFileSize ifNil:[SmallInteger maxVal]) <= (l2 resourceFileSize ifNil:[SmallInteger maxVal])]! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 18:09'! startDownload "Start downloading unloaded resources" self stopDownload. unloaded isEmpty ifTrue:[^self]. stopFlag _ false. stopSemaphore _ Semaphore new. loaderProcess _ [self loaderProcess] newProcess. loaderProcess priority: Processor lowIOPriority. loaderProcess resume.! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 17:09'! stopDownload "Stop downloading unloaded resources" loaderProcess ifNil:[^self]. stopFlag _ true. stopSemaphore signal. [loaderProcess == nil] whileFalse:[(Delay forMilliseconds: 10) wait]. stopSemaphore _ nil.! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 2/27/2001 21:42'! updateResourcesFrom: aCollector "We just assembled all the resources in a project. Include all that were newly found" self reset. "start clean" aCollector stubMap keysAndValuesDo:[:stub :res| "update all entries" resourceMap at: stub locator put: res. loaded add: stub locator. ].! ! !ResourceManager methodsFor: 'private' stamp: 'ar 3/2/2001 19:25'! abandonResourcesThat: matchBlock "Private. Forget resources that match the given argument block" resourceMap keys "need copy" do:[:loc| (matchBlock value: loc) ifTrue:[ resourceMap removeKey: loc ifAbsent:[]. loaded remove: loc ifAbsent:[]. unloaded remove: loc ifAbsent:[]. ]. ].! ! !ResourceManager methodsFor: 'private' stamp: 'ar 3/2/2001 20:35'! formChangedReminder ^[World fullReleaseCachedState; fullRepaintNeeded].! ! !ResourceManager methodsFor: 'private' stamp: 'ar 3/2/2001 17:22'! hackURL: urlString (urlString findString: '/SuperSwikiProj/') > 0 ifTrue:[^urlString copyReplaceAll: '/SuperSwikiProj/' with: '/uploads/'] ifFalse:[^urlString]! ! !ResourceManager class methodsFor: 'instance creation' stamp: 'ar 2/27/2001 14:36'! new ^super new initialize! ! !Semaphore methodsFor: 'testing' stamp: 'ar 3/2/2001 16:51'! isSignaled "Return true if this semaphore is currently signaled" ^excessSignals > 0! ! !ServerDirectory methodsFor: 'file directory' stamp: 'ar 2/26/2001 15:28'! entries "Return a collection of directory entries for the files and directories in this directory. Each entry is a five-element array: ( )." | dir ftpEntries | "We start with ftp directory entries of the form... d--------- 1 owner group 0 Apr 27 22:01 blasttest ---------- 1 owner group 93812 Jul 21 1997 COMMAND.COM 1 2 3 4 5 6 7 8 9 -- token index" self isTypeFile ifTrue: [ urlObject isAbsolute ifFalse: [urlObject default]. ^ (FileDirectory on: urlObject pathForDirectory) entries ]. dir _ self getDirectory. (dir respondsTo: #contentsOfEntireFile) ifFalse: [^ #()]. ftpEntries _ dir contentsOfEntireFile findTokens: FTPSocket crLf. "ftpEntries inspect." ^ ftpEntries collect:[:ftpEntry | self parseFTPEntry: ftpEntry] thenSelect: [:entry | entry notNil]! ! !ServerDirectory methodsFor: 'file directory' stamp: 'ar 3/2/2001 23:02'! parseFTPEntry: ftpEntry | tokens longy dateInSeconds thisYear thisMonth | thisYear _ Date today year. thisMonth _ Date today monthIndex. tokens _ ftpEntry findTokens: ' '. tokens size = 8 ifTrue: [((tokens at: 6) size ~= 3 and: [(tokens at: 5) size = 3]) ifTrue: ["Fix for case that group is blank (relies on month being 3 chars)" tokens _ tokens copyReplaceFrom: 4 to: 3 with: {'blank'}]]. tokens size >= 9 ifFalse:[^nil]. ((tokens at: 6) size ~= 3 and: [(tokens at: 5) size = 3]) ifTrue: ["Fix for case that group is blank (relies on month being 3 chars)" tokens _ tokens copyReplaceFrom: 4 to: 3 with: {'blank'}]. tokens size > 9 ifTrue: [longy _ tokens at: 9. 10 to: tokens size do: [:i | longy _ longy , ' ' , (tokens at: i)]. tokens at: 9 put: longy]. dateInSeconds _ self secondsForDay: (tokens at: 7) month: (tokens at: 6) yearOrTime: (tokens at: 8) thisMonth: thisMonth thisYear: thisYear. ^DirectoryEntry name: (tokens at: 9) "file name" creationTime: dateInSeconds "creation date" modificationTime: dateInSeconds "modification time" isDirectory: tokens first first = $d "is-a-directory flag" fileSize: tokens fifth asNumber "file size" ! ! !ServerDirectory methodsFor: 'initialize' stamp: 'ar 3/2/2001 22:32'! reset socket _ nil.! ! !ServerDirectory methodsFor: 'squeaklets' stamp: 'ar 3/2/2001 21:50'! upLoadProject: projectName members: archiveMembers retry: aBool | dir okay so m dirName idx | m _ archiveMembers detect:[:any| any fileName includes: $/] ifNone:[nil]. m == nil ifFalse:[ dirName _ m fileName copyUpTo: $/. self createDirectory: dirName. so _ socket. socket _ nil. dir _ self directoryNamed: dirName. socket _ so]. archiveMembers do:[:entry| ProgressNotification signal: '4:uploadingFile' extra:'(uploading ', entry fileName,'...)'. idx _ entry fileName indexOf: $/. idx > 0 ifTrue:[ okay _ dir putFile: entry contentStream named: (entry fileName copyFrom: idx+1 to: entry fileName size) retry: aBool. ] ifFalse:[ okay _ self putFile: entry contentStream named: entry fileName retry: aBool. ]. okay ifFalse:[^false]. ]. ProgressNotification signal: '4:uploadingFile' extra:''. ^true! ! !ServerDirectory methodsFor: 'squeaklets' stamp: 'ar 3/2/2001 19:08'! upLoadProject: projectFile named: fileNameOnServer resourceUrl: resUrl retry: aBool "Upload the given project file. If it's an archive, upload only the files that are local to the project." | archive members upload prefix | self isTypeFile ifTrue:[ ^(FileDirectory on: urlObject pathForDirectory) upLoadProject: projectFile named: fileNameOnServer resourceUrl: resUrl retry: aBool]. projectFile isZipArchive ifFalse:[^self putFile: projectFile named: fileNameOnServer retry: aBool]. projectFile binary. archive _ ZipArchive new readFrom: projectFile. resUrl last = $/ ifTrue:[prefix _ resUrl copyFrom: 1 to: resUrl size-1] "remove last slash" ifFalse:[prefix _ resUrl]. prefix _ prefix copyFrom: 1 to: (prefix lastIndexOf: $/). members _ archive members select:[:entry| "figure out where it's coming from" upload _ false. (entry fileName indexOf: $:) = 0 ifTrue:[ upload _ true. "one of the core files, e.g., project itself, resource map, meta info" ] ifFalse:[ (entry fileName asLowercase beginsWith: resUrl asLowercase) ifTrue:[ upload _ true. entry fileName: (entry fileName copyFrom: prefix size+1 to: entry fileName size). ]. ]. upload]. members _ members asArray sort:[:m1 :m2| m1 compressedSize < m2 compressedSize]. ^self upLoadProject: fileNameOnServer members: members retry: aBool.! ! !ServerDirectory class methodsFor: 'available servers' stamp: 'ar 3/2/2001 22:20'! namedServers ^Servers! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'ar 2/28/2001 13:04'! compressFile "Write a new file that has the data in me compressed in GZip format." | zipped buffer | self readOnly; binary. zipped _ self directory newFileNamed: (self name, FileDirectory dot, 'gz'). zipped binary; setFileTypeToObject. "Type and Creator not to be text, so can be enclosed in an email" zipped _ GZipWriteStream on: zipped. buffer _ ByteArray new: 50000. 'Compressing ', self fullName displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | [self atEnd] whileFalse: [ bar value: self position. zipped nextPutAll: (self nextInto: buffer)]. zipped close. self close]. ^zipped! ! !StandardFileStream methodsFor: 'browser requests' stamp: 'ar 2/26/2001 15:58'! primBrowserReady ^nil! ! !StandardFileStream methodsFor: 'browser requests' stamp: 'ar 2/26/2001 15:59'! waitBrowserReadyFor: timeout ifFail: errorBlock | startTime delay okay | okay _ self primBrowserReady. okay ifNil:[^errorBlock value]. okay ifTrue: [^true]. startTime _ Time millisecondClockValue. delay _ Delay forMilliseconds: 100. [(Time millisecondsSince: startTime) < timeout] whileTrue: [ delay wait. okay _ self primBrowserReady. okay ifNil:[^errorBlock value]. okay ifTrue: [^true]]. ^errorBlock value! ! !SuperSwikiServer methodsFor: 'for real' stamp: 'ar 3/2/2001 14:36'! directoryNames ^self entries select:[:each| each isDirectory] thenCollect: [ :each | each name]! ! !SuperSwikiServer methodsFor: 'for real' stamp: 'ar 3/2/2001 14:36'! entries | answer c first | answer _ self sendToSwikiProjectServer: { 'action: listallprojects'. }. (answer beginsWith: 'OK') ifFalse: [^#()]. c _ OrderedCollection new. first _ true. answer linesDo: [ :x | first ifFalse: [c add: (Compiler evaluate: x)]. first _ false. ]. ^c ! ! !SuperSwikiServer methodsFor: 'for real' stamp: 'ar 3/2/2001 14:36'! fileNames ^self entries select:[:each| each isDirectory not] thenCollect: [ :each | each name]! ! !SuperSwikiServer methodsFor: 'squeaklets' stamp: 'ar 3/2/2001 21:11'! upLoadProject: projectName members: archiveMembers retry: aBool | answer | archiveMembers do:[:entry| ProgressNotification signal: '4:uploadingFile' extra:'(uploading ', entry fileName,'...)'. answer _ self sendToSwikiProjectServer: { 'uploadproject2: ', entry fileName. entry contents. }. answer = 'OK' ifFalse:[ self inform:'Server responded ', answer. ^false]. ]. ProgressNotification signal: '4:uploadingFile' extra:''. ^true! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'ar 2/27/2001 15:05'! isBigEndian ^self endianness == #big! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'ar 2/27/2001 15:05'! isLittleEndian ^self endianness == #little! ! !Url methodsFor: 'classification' stamp: 'ar 2/27/2001 22:07'! hasRemoteContents "Return true if the receiver describes some remotely accessible content. Typically, this should only return if we could retrieve the contents on an arbitrary place in the outside world using a standard browser. In other words: If you can get to it from the next Internet Cafe, return true, else return false." ^false! ! !FtpUrl methodsFor: 'downloading' stamp: 'ar 3/2/2001 22:32'! retrieveContents "currently assumes directories end in /, and things that don't end in / are files. Also, doesn't handle errors real well...." | server contents pathString listing auth idx fileName serverName userName password | pathString _ self pathString. pathString _ pathString copyFrom: 2 to: pathString size. "remove the leading /" pathString last = $/ ifTrue:["directory?!!" fileName _ nil. ] ifFalse:[ fileName _ pathString copyFrom: (pathString lastIndexOf: $/)+1 to: pathString size. pathString _ pathString copyFrom: 1 to: (pathString lastIndexOf: $/) - 1. ]. auth _ self authority. idx _ auth indexOf: $@. idx > 0 ifTrue:[ serverName _ (auth copyFrom: idx+1 to: auth size). userName _ (auth copyFrom: 1 to: idx-1). password _ nil. ] ifFalse:[ serverName _ auth. userName _ 'anonymous'. password _ 'SqueakUser'. ]. server _ ServerDirectory namedServers detect:[:s| s isTypeFTP and:[s server asLowercase = serverName asLowercase]] ifNone:[nil]. server ifNil:[ server _ ServerDirectory new. server server: serverName. ] ifNotNil:[server _ server copy reset]. server user: userName. password ifNotNil:[server password: password]. server directory: pathString. fileName == nil ifFalse:[ "a file" contents _ (server getFileNamed: fileName). server sleep. (contents respondsTo: #contents) ifTrue: [ "the file exists--return it" ^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) content: contents contents ] ifFalse: [ "some error" ^nil ]. ]. "a directory?" listing _ String streamContents: [ :stream | stream nextPutAll: '', self pathString, ''; cr. stream nextPutAll: '

Listing for ', self pathString, '

'; cr. stream nextPutAll: '
    '; cr. server entries do: [ :entry | stream nextPutAll: '
  • '; nextPutAll: ''; nextPutAll: entry name; nextPutAll: ''; cr ] ]. server sleep. ^MIMEDocument contentType: 'text/html' content: listing! ! !FtpUrl methodsFor: 'testing' stamp: 'ar 2/27/2001 22:07'! hasRemoteContents "Return true if the receiver describes some remotely accessible content. Typically, this should only return if we could retrieve the contents on an arbitrary place in the outside world using a standard browser. In other words: If you can get to it from the next Internet Cafe, return true, else return false." ^true! ! !HttpUrl methodsFor: 'testing' stamp: 'ar 2/27/2001 22:08'! hasRemoteContents "Return true if the receiver describes some remotely accessible content. Typically, this should only return if we could retrieve the contents on an arbitrary place in the outside world using a standard browser. In other words: If you can get to it from the next Internet Cafe, return true, else return false." ^true! ! !ZipArchive methodsFor: 'archive operations' stamp: 'ar 2/27/2001 14:00'! readFrom: aStreamOrFileName | stream name eocdPosition | stream _ aStreamOrFileName isStream ifTrue: [ name _ aStreamOrFileName name. aStreamOrFileName ] ifFalse: [ StandardFileStream oldFileNamed: (name _ aStreamOrFileName) ]. stream binary. self findEndOfCentralDirectoryFrom: stream. eocdPosition _ stream position. self readEndOfCentralDirectoryFrom: stream. stream position: eocdPosition - centralDirectorySize. self readMembersFrom: stream named: name. ! ! !ZipArchive methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:47'! close self members do:[:m| m close].! ! !ZipArchive class methodsFor: 'constants' stamp: 'ar 2/27/2001 13:38'! validSignatures "Return the valid signatures for a zip file" ^Array with: LocalFileHeaderSignature with: CentralDirectoryFileHeaderSignature with: EndOfCentralDirectorySignature! ! !ZipArchiveMember methodsFor: 'TODO' stamp: 'ar 2/28/2001 14:01'! compressDataTo: aStream "Copy my deflated data to the given stream." | encoder startPos endPos | encoder _ ZipWriteStream on: aStream. startPos _ aStream position. [ readDataRemaining > 0 ] whileTrue: [ | data | data _ self readRawChunk: (4096 min: readDataRemaining). encoder nextPutAll: data asByteArray. readDataRemaining _ readDataRemaining - data size. ]. encoder finish. "not close!!" endPos _ aStream position. compressedSize _ endPos - startPos. crc32 _ encoder crc. ! ! !ZipArchiveMember methodsFor: 'accessing' stamp: 'ar 2/27/2001 14:30'! contentStream "Answer my contents as a string." | s | s _ RWBinaryOrTextStream on: (String new: self uncompressedSize). self extractTo: s. ^s reset! ! !ZipFileMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'! close stream ifNotNil:[stream close].! ! !ZipFileMember methodsFor: 'private-reading' stamp: 'ar 2/27/2001 13:57'! readFrom: aStream "assumes aStream positioned after CD header; leaves stream positioned after my CD entry" self readCentralDirectoryFileHeaderFrom: aStream. self readLocalDirectoryFileHeaderFrom: aStream. self endRead. ! ! !ZipNewFileMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:50'! close stream ifNotNil:[stream close].! ! !ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 2/28/2001 13:39'! close self deflateBlock. self flushBlock: true. encoder close.! ! !ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 2/27/2001 13:23'! finish "Finish pending operation. Do not close output stream." self deflateBlock. self flushBlock: true. encoder flush.! ! Notification subclass: #ProgressNotification instanceVariableNames: 'amount done extra ' classVariableNames: '' poolDictionaries: '' category: 'System-Exceptions Kernel'!