>From 2c7e68e58596234b7e50db8c0073baa34140baed Mon Sep 17 00:00:00 2001
From: Gwenael Casaccio
Date: Wed, 18 Dec 2013 16:33:06 +0100
Subject: [PATCH] Refactor package classes (extract the pretty printer and the
parser)
---
ChangeLog | 6 +
kernel/PkgLoader.st | 721 ++++++++++++++++++++++++++++++----------------------
2 files changed, 421 insertions(+), 306 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 7b6f5e8..cbbcdd2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2013-12-18 Gwenael Casaccio
+
+ * kernel/PkgLoader.st: Extract the parser from their classes
+ into a ParseXMLPackage and a ParseXMLPackageGroup. The same
+ is done for the pretty printer.
+
2013-12-08 Holger Hans Peter Freyther
* kernel/Regex.st: Check for isEmpty of the Interval before
diff --git a/kernel/PkgLoader.st b/kernel/PkgLoader.st
index 53d9367..0e98733 100644
--- a/kernel/PkgLoader.st
+++ b/kernel/PkgLoader.st
@@ -330,50 +330,8 @@ XML.'>
parse: file [
- | open ch cdata tag package allPackages |
- open := false.
- allPackages := OrderedCollection new.
-
- [cdata := cdata isNil
- ifTrue: [file upTo: $<]
- ifFalse: [cdata , (file upTo: $<)].
- file atEnd]
- whileFalse:
- [cdata trimSeparators isEmpty
- ifFalse: [^self error: 'unexpected character data'].
- ch := file peek.
- ch == $! ifTrue: [file skipTo: $>].
- ch == $/
- ifTrue:
- [file next.
- (tag := file upTo: $>) = 'packages' ifTrue: [^self].
- ^self error: 'unmatched end tag ' , tag].
- ch isAlphaNumeric
- ifTrue:
- [open
- ifFalse:
- [tag := file upTo: $>.
- tag = 'package'
- ifTrue: [package := Package new parse: file tag: 'package']
- ifFalse:
- [tag = 'packages' ifFalse: [^self error: 'expected packages tag'].
- open := true]]
- ifTrue:
- [file skip: -1.
- package := Package parse: file].
- package notNil
- ifTrue:
- [package name isNil
- ifTrue: [^self error: 'missing package name in ' , self fileName].
-
- [self testPackageValidity: package.
- self packages at: package name put: package.
- allPackages add: package]
- on: PackageSkip
- do: [:ex | ex return].
- open ifFalse: [^allPackages]].
- package := nil]].
- ^allPackages
+
+ ^ ParseXMLPackageGroup parse: file into: self
]
testPackageValidity: package [
@@ -455,83 +413,30 @@ PackageContainer subclass: PackageDirectory [
Namespace current: Kernel [
-Object subclass: PackageInfo [
- | name |
-
-
-
-
- createNamespace [
- "Create the path of namespaces indicated by our namespace field in
- dot notation, and answer the final namespace"
-
-
- | ns |
- ns := Smalltalk.
- self namespace isNil ifTrue: [^ns].
- (self namespace subStrings: $.) do:
- [:each |
- | key |
- key := each asSymbol.
- (ns includesKey: key) ifFalse: [ns addSubspace: key].
- ns := ns at: key].
- ^ns
- ]
-
- fileIn [
- "File in the given package and its dependencies."
-
-
- self name isNil
- ifTrue:
- ["Other packages cannot be dependent on this one."
-
- PackageLoader fileInPackages: self prerequisites.
- self primFileIn]
- ifFalse: [PackageLoader fileInPackage: self name]
- ]
-
- fullPathsOf: aCollection [
- "Resolve the names in aCollection according to the base directories
- in baseDirectories, and return the collection with the FilePaths.
- Raise a PackageNotAvailable exception if no directory was found for one
- or more files in aCollection."
+Object subclass: PackageInfoPrinter [
-
- ^aCollection collect:
- [:fileName | self fullPathOf: fileName]
- ]
+ | package stream |
- / fileName [
- "Resolve the file name according to the base directories in
- baseDirectories, and return a FilePath for the full filename.
- Raise a PackageNotAvailable exception if no directory was found
- for fileName."
+ PackageInfoPrinter class >> package: aPackage stream: aStream [
-
- ^self fullPathOf: fileName
+ ^ self new
+ package: aPackage stream: aStream
]
- fullPathOf: fileName [
-
- self subclassResponsibility
- ]
+ package: aPackage stream: aStream [
- isDisabled [
-
- ^false
+ package := aPackage.
+ stream := aStream.
]
- printXmlOn: aStream collection: aCollection tag: aString indent: indent [
+ printXml: aCollection tag: aString indent: indent [
"Private - Print aCollection on aStream as a sequence of aString
tags."
aCollection do:
[:each |
- aStream
+ stream
nextPutAll: ' <';
nextPutAll: aString;
nextPut: $>;
@@ -543,144 +448,220 @@ XML.'>
space: indent]
]
- printOn: aStream [
-
- self printOn: aStream indent: 0
- ]
-
- printOn: aStream indent: indent [
-
- self
- printOn: aStream
- tag: 'package'
- indent: indent
- ]
-
- printOn: aStream tag: tag indent: indent [
+ print: tag indent: indent [
"Print a representation of the receiver on aStream (it happens
to be XML."
- aStream
+ stream
nextPut: $<;
nextPutAll: tag;
nextPut: $>;
nl;
space: indent.
- self name isNil
+ package name isNil
ifFalse:
- [aStream
+ [stream
nextPutAll: ' ';
- nextPutAll: self name;
+ nextPutAll: package name;
nextPutAll: '';
nl;
space: indent].
- self url isNil
+ package url isNil
ifFalse:
- [aStream
+ [stream
nextPutAll: ' ';
- nextPutAll: self url;
+ nextPutAll: package url;
nextPutAll: '';
nl;
space: indent].
- self namespace isNil
+ package namespace isNil
ifFalse:
- [aStream
+ [stream
nextPutAll: ' ';
- nextPutAll: self namespace;
+ nextPutAll: package namespace;
nextPutAll: '';
nl;
space: indent].
- self test isNil
+ package test isNil
ifFalse:
- [aStream space: 2.
- self test
- printOn: aStream
+ [stream space: 2.
+ package test
+ printOn: stream
tag: 'test'
indent: indent + 2.
- aStream
+ stream
nl;
space: indent].
self
- printXmlOn: aStream
- collection: self features asSortedCollection
+ printXml: package features asSortedCollection
tag: 'provides'
indent: indent.
self
- printXmlOn: aStream
- collection: self prerequisites asSortedCollection
+ printXml: package prerequisites asSortedCollection
tag: 'prereq'
indent: indent.
self
- printXmlOn: aStream
- collection: self sunitScripts
+ printXml: package sunitScripts
tag: 'sunit'
indent: indent.
self
- printXmlOn: aStream
- collection: self callouts asSortedCollection
+ printXml: package callouts asSortedCollection
tag: 'callout'
indent: indent.
self
- printXmlOn: aStream
- collection: self libraries asSortedCollection
+ printXml: package libraries asSortedCollection
tag: 'library'
indent: indent.
self
- printXmlOn: aStream
- collection: self modules asSortedCollection
+ printXml: package modules asSortedCollection
tag: 'module'
indent: indent.
- self relativeDirectory isNil
+ package relativeDirectory isNil
ifFalse:
- [aStream
+ [stream
nextPutAll: ' ';
- nextPutAll: self relativeDirectory;
+ nextPutAll: package relativeDirectory;
nextPutAll: '';
nl;
space: indent].
- self files size + self builtFiles size > 1
+ package files size + package builtFiles size > 1
ifTrue:
- [aStream
+ [stream
nl;
space: indent].
self
- printXmlOn: aStream
- collection: self fileIns
+ printXml: package fileIns
tag: 'filein'
indent: indent.
self
- printXmlOn: aStream
- collection: (self files copy removeAll: self fileIns ifAbsent: []; yourself)
+ printXml: (package files copy removeAll: package fileIns ifAbsent: []; yourself)
tag: 'file'
indent: indent.
self
- printXmlOn: aStream
- collection: self builtFiles
+ printXml: package builtFiles
tag: 'built-file'
indent: indent.
- self startScript isNil
+ package startScript isNil
ifFalse:
- [aStream
+ [stream
nextPutAll: ' ';
- nextPutAll: self startScript;
+ nextPutAll: package startScript;
nextPutAll: '';
nl;
space: indent].
- self stopScript isNil
+ package stopScript isNil
ifFalse:
- [aStream
+ [stream
nextPutAll: ' ';
- nextPutAll: self stopScript;
+ nextPutAll: package stopScript;
nextPutAll: '';
nl;
space: indent].
- aStream
+ stream
nextPutAll: '';
nextPutAll: tag;
nextPut: $>
]
+]
+
+]
+
+
+Namespace current: Kernel [
+
+Object subclass: PackageInfo [
+ | name |
+
+
+
+
+ createNamespace [
+ "Create the path of namespaces indicated by our namespace field in
+ dot notation, and answer the final namespace"
+
+
+ | ns |
+ ns := Smalltalk.
+ self namespace isNil ifTrue: [^ns].
+ (self namespace subStrings: $.) do:
+ [:each |
+ | key |
+ key := each asSymbol.
+ (ns includesKey: key) ifFalse: [ns addSubspace: key].
+ ns := ns at: key].
+ ^ns
+ ]
+
+ fileIn [
+ "File in the given package and its dependencies."
+
+
+ self name isNil
+ ifTrue:
+ ["Other packages cannot be dependent on this one."
+
+ PackageLoader fileInPackages: self prerequisites.
+ self primFileIn]
+ ifFalse: [PackageLoader fileInPackage: self name]
+ ]
+
+ fullPathsOf: aCollection [
+ "Resolve the names in aCollection according to the base directories
+ in baseDirectories, and return the collection with the FilePaths.
+ Raise a PackageNotAvailable exception if no directory was found for one
+ or more files in aCollection."
+
+
+ ^aCollection collect:
+ [:fileName | self fullPathOf: fileName]
+ ]
+
+ / fileName [
+ "Resolve the file name according to the base directories in
+ baseDirectories, and return a FilePath for the full filename.
+ Raise a PackageNotAvailable exception if no directory was found
+ for fileName."
+
+
+ ^self fullPathOf: fileName
+ ]
+
+ fullPathOf: fileName [
+
+ self subclassResponsibility
+ ]
+
+ isDisabled [
+
+ ^false
+ ]
+
+ printOn: aStream [
+
+ self printOn: aStream indent: 0
+ ]
+
+ printOn: aStream indent: indent [
+
+ self
+ printOn: aStream
+ tag: 'package'
+ indent: indent
+ ]
+
+ printOn: aStream tag: tag indent: indent [
+ "Print a representation of the receiver on aStream (it happens
+ to be XML."
+
+
+ (PackageInfoPrinter package: self stream: aStream)
+ print: tag indent: indent
+ ]
+
name [
"Answer the name of the package."
@@ -1112,9 +1093,275 @@ ExternalPackage subclass: StarPackage [
+Namespace current: Kernel [
+
+Object subclass: ParseXMLPackageGroup [
+ | stream packages group |
+ ParseXMLPackageGroup class >> parse: aStream into: aPackageGroup [
+ ^ self new
+ stream: aStream into: aPackageGroup ;
+ parse;
+ packages
+ ]
+
+ packages [
+
+ ^ packages
+ ]
+
+ stream: aStream into: aPackageGroup [
+
+ stream := aStream.
+ group := aPackageGroup.
+ ]
+
+ parse [
+ | open ch cdata tag package |
+ open := false.
+ packages := OrderedCollection new.
+
+ [cdata := cdata isNil
+ ifTrue: [stream upTo: $<]
+ ifFalse: [cdata , (stream upTo: $<)].
+ stream atEnd]
+ whileFalse:
+ [cdata trimSeparators isEmpty
+ ifFalse: [^self error: 'unexpected character data'].
+ ch := stream peek.
+ ch == $! ifTrue: [stream skipTo: $>].
+ ch == $/
+ ifTrue:
+ [stream next.
+ (tag := stream upTo: $>) = 'packages' ifTrue: [^self].
+ ^self error: 'unmatched end tag ' , tag].
+ ch isAlphaNumeric
+ ifTrue:
+ [open
+ ifFalse:
+ [tag := stream upTo: $>.
+ tag = 'package'
+ ifTrue: [package := ParseXMLPackage parsePackage: stream]
+ ifFalse:
+ [tag = 'packages' ifFalse: [^self error: 'expected packages tag'].
+ open := true]]
+ ifTrue:
+ [stream skip: -1.
+ package := Package parse: stream].
+ package notNil
+ ifTrue:
+ [package name isNil
+ ifTrue: [^self error: 'missing package name in ' , self fileName].
+
+ [group testPackageValidity: package.
+ group packages at: package name put: package.
+ packages add: package]
+ on: PackageSkip
+ do: [:ex | ex return].
+ open ifFalse: [^packages]].
+ package := nil]].
+ ^packages
+ ]
+]
+
+Object subclass: ParseXMLPackage [
+
+ | stream package |
+
+ ParseXMLPackage class [ | Tags | ]
+
+ ParseXMLPackage class >> tags [
+
+
+ ^ Tags ifNil: [ Tags := Dictionary from: {
+ 'file' -> #addFile:.
+ 'filein' -> #addFileIn:.
+ 'prereq' -> #addPrerequisite:.
+ 'provides' -> #addFeature:.
+ 'module' -> #addModule:.
+ 'directory' -> #relativeDirectory:.
+ 'name' -> #name:.
+ 'url' -> #url:.
+ 'version' -> #parseVersion:.
+ 'namespace' -> #namespace:.
+ 'library' -> #addLibrary:.
+ 'built-file' -> #addBuiltFile:.
+ 'sunit' -> #addSunitScript:.
+ 'start' -> #startScript:.
+ 'stop' -> #stopScript:.
+ 'callout' -> #addCallout: } ]
+ ]
+
+
+ ParseXMLPackage class >> parseTest: aStream [
+
+ ^ self new
+ parseTestPackage: aStream;
+ package
+ ]
+
+ ParseXMLPackage class >> parsePackage: aStream [
+
+ ^ self new
+ parsePackage: aStream;
+ package
+ ]
+
+ ParseXMLPackage class >> parse: aStream [
+
+ ^ self new
+ parse: aStream;
+ package
+ ]
+
+ parse: aStream [
+
+ | ch tag |
+ stream := aStream.
+
+ [(stream upTo: $<) trimSeparators isEmpty
+ ifFalse: [self error: 'unexpected cdata'].
+ stream atEnd ifTrue: [self error: 'expected start tag'].
+ ch := stream peek.
+ ch == $! ifTrue: [stream skipTo: $>].
+ ch == $/ ifTrue: [self error: 'unexpected end tag '].
+ ch isAlphaNumeric
+ ifTrue:
+ [tag := stream upTo: $>.
+ tag = 'package' ifTrue: [package := Package new. ^ self parseTag: tag].
+ tag = 'disabled-package'
+ ifTrue: [package := DisabledPackage new. ^ self parseTag: tag]]]
+ repeat
+
+ ]
+
+ parsePackage: aStream [
+
+ stream := aStream.
+ package := Package new.
+ self parseTag: 'package'
+ ]
+ parseTestPackage: aStream [
+
+ stream := aStream.
+ package := TestPackage new.
+ self parseTag: 'test'
+ ]
+
+ parseTag: openingTag [
+
+ | stack cdata ch tag testPackage words |
+ stack := OrderedCollection new.
+ stack addLast: openingTag.
+
+ [
+ [cdata := cdata isNil
+ ifTrue: [stream upTo: $<]
+ ifFalse: [cdata , (stream upTo: $<)].
+ stream atEnd]
+ whileFalse:
+ [ch := stream peek.
+ ch == $! ifTrue: [stream skipTo: $>].
+ ch == $/
+ ifTrue:
+ [tag := stack removeLast.
+ stream next.
+ (stream upTo: $>) = tag
+ ifFalse: [^self error: 'error in packages file: unmatched end tag ' , tag ].
+ tag = openingTag ifTrue: [ ^ self ].
+ package checkTagIfInPath: tag.
+ package perform: (self class tags at: tag ifAbsent: [ self error: 'invalid tag ', tag ]) with: cdata.
+ cdata := nil ].
+ ch isAlphaNumeric
+ ifTrue:
+ [tag := stream upTo: $>.
+ words := tag substrings.
+ words first = 'dir' ifTrue: [
+ self
+ dir: stream
+ tag: (self parseAttributes: (tag copyFrom: words first size + 1)) ]
+ ifFalse: [
+ words first = 'test'
+ ifTrue: [package test: (ParseXMLPackage parseTest: stream)]
+ ifFalse: [stack addLast: tag] ].
+ cdata trimSeparators isEmpty
+ ifFalse: [^self error: 'unexpected character data'].
+ cdata := nil]]]
+ ensure:
+ [stack isEmpty
+ ifFalse:
+ [self error: 'error in packages file: unmatched start tags'
+ , stack asArray printString]]
+ ]
+
+ parseAttributes: aString [
+
+ | attribute args key value terminator ch |
+ attribute := ReadStream on: aString.
+ args := LookupTable new.
+ [
+ attribute atEnd ifTrue: [^args].
+ attribute peek isSeparator ifFalse: [
+ self error: 'expected separator'].
+ [
+ attribute next.
+ attribute atEnd ifTrue: [^args].
+ attribute peek isSeparator ] whileTrue.
+ attribute peek isAlphaNumeric ifFalse: [
+ self error: 'expected attribute'].
+
+ key := String streamContents: [ :s |
+ [
+ attribute atEnd ifTrue: [
+ self error: 'expected attribute'].
+ ch := attribute next. ch = $= ] whileFalse: [
+ ch isAlphaNumeric ifFalse: [
+ self error: 'invalid attribute name'].
+ s nextPut: ch ] ].
+
+ terminator := attribute next.
+ (terminator = $' or: [terminator = $"]) ifFalse: [
+ self error: 'expected single or double quote'].
+
+ value := String streamContents: [ :s |
+ [
+ attribute atEnd ifTrue: [
+ self error: 'expected %1' % { terminator }].
+ ch := attribute next. ch = terminator ] whileFalse: [
+ s nextPut: ch ] ].
+ args at: key put: value.
+ ] repeat
+ ]
+
+ dir: file tag: aDictionary [
+ | oldPath newPath |
+ newPath := aDictionary
+ at: 'name'
+ ifAbsent: [ self error: 'name attribute is not present in a dir tag' ].
+ newPath isEmpty
+ ifTrue: [ self error: 'name attribute is empty' ].
+
+ oldPath := package path.
+ newPath := oldPath, newPath.
+ (newPath notEmpty and: [newPath last isPathSeparator not])
+ ifTrue: [ newPath := newPath, Directory pathSeparatorString].
+ package path: newPath.
+ self parseTag: 'dir'.
+ package path: oldPath.
+ ]
+
+ package [
+
+ ^ package
+ ]
+]
+
+]
+
+
+
Namespace current: Kernel [
Object subclass: Version [
@@ -1202,48 +1449,11 @@ Kernel.PackageInfo subclass: Package [
information on a Smalltalk package, and can output my description in
XML.'>
- Package class [ | Tags | ]
-
- Package class >> tags [
-
-
- ^ Tags ifNil: [ Tags := Dictionary from: {
- 'file' -> #addFile:.
- 'filein' -> #addFileIn:.
- 'prereq' -> #addPrerequisite:.
- 'provides' -> #addFeature:.
- 'module' -> #addModule:.
- 'directory' -> #relativeDirectory:.
- 'name' -> #name:.
- 'url' -> #url:.
- 'version' -> #parseVersion:.
- 'namespace' -> #namespace:.
- 'library' -> #addLibrary:.
- 'built-file' -> #addBuiltFile:.
- 'sunit' -> #addSunitScript:.
- 'start' -> #startScript:.
- 'stop' -> #stopScript:.
- 'callout' -> #addCallout: } ]
- ]
-
Package class >> parse: file [
"Answer a package from the XML description in file."
- | ch tag |
-
- [(file upTo: $<) trimSeparators isEmpty
- ifFalse: [self error: 'unexpected cdata'].
- file atEnd ifTrue: [self error: 'expected start tag'].
- ch := file peek.
- ch == $! ifTrue: [file skipTo: $>].
- ch == $/ ifTrue: [self error: 'unexpected end tag '].
- ch isAlphaNumeric
- ifTrue:
- [tag := file upTo: $>.
- tag = 'package' ifTrue: [^Package new parse: file tag: tag].
- tag = 'disabled-package'
- ifTrue: [^DisabledPackage new parse: file tag: tag]]]
- repeat
+
+ ^ ParseXMLPackage parse: file
]
test [
@@ -1610,107 +1820,6 @@ XML.'>
(aString = 'file' or: [ aString = 'filein' or: [ aString = 'built-file' ] ]) ifFalse: [ self error: 'invalid tag in a dir tag ', aString ]
]
- dir: file tag: aDictionary [
- | oldPath newPath |
- newPath := aDictionary
- at: 'name'
- ifAbsent: [ self error: 'name attribute is not present in a dir tag' ].
- newPath isEmpty
- ifTrue: [ self error: 'name attribute is empty' ].
-
- oldPath := self path.
- newPath := oldPath, newPath.
- (newPath notEmpty and: [newPath last isPathSeparator not])
- ifTrue: [ newPath := newPath, Directory pathSeparatorString].
- self path: newPath.
- self parse: file tag: 'dir'.
- self path: oldPath.
- ]
-
- parseAttributes: aString [
-
- | attribute args key value terminator ch |
- attribute := ReadStream on: aString.
- args := LookupTable new.
- [
- attribute atEnd ifTrue: [^args].
- attribute peek isSeparator ifFalse: [
- self error: 'expected separator'].
- [
- attribute next.
- attribute atEnd ifTrue: [^args].
- attribute peek isSeparator ] whileTrue.
- attribute peek isAlphaNumeric ifFalse: [
- self error: 'expected attribute'].
-
- key := String streamContents: [ :s |
- [
- attribute atEnd ifTrue: [
- self error: 'expected attribute'].
- ch := attribute next. ch = $= ] whileFalse: [
- ch isAlphaNumeric ifFalse: [
- self error: 'invalid attribute name'].
- s nextPut: ch ] ].
-
- terminator := attribute next.
- (terminator = $' or: [terminator = $"]) ifFalse: [
- self error: 'expected single or double quote'].
-
- value := String streamContents: [ :s |
- [
- attribute atEnd ifTrue: [
- self error: 'expected %1' % { terminator }].
- ch := attribute next. ch = terminator ] whileFalse: [
- s nextPut: ch ] ].
- args at: key put: value.
- ] repeat
- ]
-
- parse: file tag: openingTag [
-
- | stack cdata ch tag testPackage words |
- stack := OrderedCollection new.
- stack addLast: openingTag.
-
- [
- [cdata := cdata isNil
- ifTrue: [file upTo: $<]
- ifFalse: [cdata , (file upTo: $<)].
- file atEnd]
- whileFalse:
- [ch := file peek.
- ch == $! ifTrue: [file skipTo: $>].
- ch == $/
- ifTrue:
- [tag := stack removeLast.
- file next.
- (file upTo: $>) = tag
- ifFalse: [^self error: 'error in packages file: unmatched end tag ' , tag ].
- tag = openingTag ifTrue: [ ^ self ].
- self checkTagIfInPath: tag.
- self perform: (self class tags at: tag ifAbsent: [ self error: 'invalid tag ', tag ]) with: cdata.
- cdata := nil ].
- ch isAlphaNumeric
- ifTrue:
- [tag := file upTo: $>.
- words := tag substrings.
- words first = 'dir' ifTrue: [
- self
- dir: file
- tag: (self parseAttributes: (tag copyFrom: words first size + 1)) ]
- ifFalse: [
- words first = 'test'
- ifTrue: [self test: (TestPackage new parse: file tag: tag)]
- ifFalse: [stack addLast: tag] ].
- cdata trimSeparators isEmpty
- ifFalse: [^self error: 'unexpected character data'].
- cdata := nil]]]
- ensure:
- [stack isEmpty
- ifFalse:
- [self error: 'error in packages file: unmatched start tags'
- , stack asArray printString]]
- ]
]
--
1.8.3.2