On Sat, 2010-01-02 at 13:46 +0100, Paolo Bonzini wrote: > On 01/02/2010 01:43 PM, Gwenael Casaccio wrote: > > Hi, > > > > I'm working an a new command for displaying packages inside a > > repository. Basicly it will download a file (repository.xml) and parse > > it so we have the list of packages inside a repository. > > Uhm, you want me to do that in PHP too for smalltalk.gnu.org... ;-)
;) > > > I would like to make some small changes to the pckloader.st create a new > > namespace Package instead of Kernel ?? and split the one file in > > multiple file (or directory). Do you agree or not :D ? > > Naming the namespace Package is a problem because you'd have a Package > class within a same-name namespace. I agree that putting them in Kernel > is suboptimal. For 3.2 I'd rather keep things as is, we have to start > the stabilization somewhere. > > Paolo So here is the first version of the patch : I've made a tiny XML parser (very very simple ^^), a new PckRepositoryList command and a new class PackageRepository which stores packages from a repository. Any comments, remarks are welcomes I've found also a minor "bug" when I've bootstraped the image if there are errors the compiler display nothing, may be an improvement for the 3.3 ;). Gwen
commit 29c338d542628a2729931496f49ea820c4575ea2 Author: Gwenael Casaccio <[email protected]> Date: Sun Jan 3 19:03:54 2010 +0100 New ignore Display list of packages diff --git a/.gitignore b/.gitignore index 504cfce..9c8f800 100644 --- a/.gitignore +++ b/.gitignore @@ -34,3 +34,12 @@ termnorm /gst-tool /gst.im /smalltalk-mode-init.el + +/libgst/genbc-decl.c +/libgst/genbc-decl.h +/libgst/genpr-parse.c +/libgst/genpr-parse.h +snprintfv/snprintfv/filament.h +snprintfv/snprintfv/printf.h +snprintfv/snprintfv/stream.h +tests/testsuite diff --git a/kernel/PkgLoader.st b/kernel/PkgLoader.st index 840890f..aef5ee9 100644 --- a/kernel/PkgLoader.st +++ b/kernel/PkgLoader.st @@ -42,6 +42,74 @@ Notification subclass: PackageSkip [ ] +Namespace current: Kernel [ + +Smalltalk.Object subclass: TinyXMLParser [ + <category: 'package-parser'> + <comment: 'I am a tiny XML parser'> + + | stream endTag contents | + + TinyXMLParser class >> on: aStream [ + <category: 'instance creation'> + + ^ self new + initialize; + stream: aStream + ] + + initialize [ + <category: 'initialization'> + + endTag := false. + contents := ''. + ] + + stream: aStream [ + <category: 'accessing'> + + stream := aStream + ] + + nextTag [ + <category: 'parsing'> + + stream upTo: $<. + stream atEnd ifTrue: [ self error: 'unmatched tag' ]. + (endTag := stream peek == $/) ifTrue: [ stream next ]. + contents := stream upTo: $>. + ^ self text + ] + + nextContents [ + <category: 'parsing'> + + contents := stream upTo: $<. + stream atEnd ifTrue: [ self error: 'unmatched tag' ]. + stream skip: - 1. + ^ contents + ] + + isStartTag [ + <category: 'testing'> + + ^ self isEndTag not + ] + + isEndTag [ + <category: 'testing'> + + ^ endTag + ] + + text [ + <category: 'accessing'> + + ^ contents + ] +] + +] Namespace current: SystemExceptions [ @@ -1679,6 +1747,64 @@ that package. ] + +Namespace current: Kernel [ +Smalltalk.Object subclass: PackageRepository [ + + | url packages | + + PackageRepository class >> parse: aStream [ + <category: 'instance creation'> + + ^ self new + parse: aStream; + yourself + ] + + packages [ + <category: 'accessing'> + + ^ packages ifNil: [ packages := OrderedCollection new ] + ] + + addPackage: aString [ + <category: 'packages accessing'> + + self packages add: aString + ] + + packagesDo: aOneArgBlock [ + <category: 'packages enumerating'> + + self packages do: aOneArgBlock + ] + + parse: aStream [ + <category: 'parsing'> + + | parser | + parser := TinyXMLParser on: aStream. + parser nextTag = 'repository' ifFalse: [ self error: 'Should be a repository : ', parser text ]. + [ parser nextTag = 'repository' ] whileFalse: [ + parser text = 'package' ifFalse: [ self error: 'Bad repository file' ]. + self addPackage: parser nextContents. + parser nextTag = 'package' ifFalse: [ self error: 'Bad repository file' ] ] + ] + + printOn: aStream [ + "Print a represention of the receiver on aStream." + + <category: 'printing'> + super printOn: aStream. + aStream nl; nl; nextPutAll: 'packages:'; nl. + self packagesDo: [ :each | + aStream + tab; + nextPutAll: each; + nl ] + ] +] +] Object subclass: PackageLoader [ diff --git a/scripts/Package.st b/scripts/Package.st index fbf2928..6115f7d 100644 --- a/scripts/Package.st +++ b/scripts/Package.st @@ -202,10 +202,10 @@ Kernel.PackageContainer subclass: PackageCheckout [ mainPackage := addedPackages first. MainPackage use: mainPackage during: [ mainPackage prerequisites printNl do: [ :each || file | - ((each startsWith: mainPackage name, '-') and: [ + ((each startsWith: mainPackage name, '-') and: [ (file := mainPackage baseDirectories first - / (each copyFrom: mainPackage name size + 2) - / 'package.xml') exists ]) + / (each copyFrom: mainPackage name size + 2) + / 'package.xml') exists ]) ifTrue: [ self parseFile: file ]]]. ^addedPackages @@ -228,11 +228,11 @@ PackageCheckout subclass: SvnPackageCheckout [ | realUrl command saveDir | self checkoutDirectory exists ifFalse: [ - self checkoutDirectory emitMkdir. + self checkoutDirectory emitMkdir. realUrl := url copy. url scheme = 'svn+http' ifTrue: [ realUrl scheme: 'http' ]. url host = '' ifTrue: [ realUrl := realUrl path ]. - command := 'svn checkout %1 .' % {realUrl} ] + command := 'svn checkout %1 .' % {realUrl} ] ifTrue: [ command := 'svn update' ]. @@ -240,7 +240,7 @@ PackageCheckout subclass: SvnPackageCheckout [ saveDir := Directory working. Command execute: [ - Directory working: self checkoutDirectory. + Directory working: self checkoutDirectory. Smalltalk system: command ] ensure: [ Directory working: saveDir ] ] @@ -252,12 +252,12 @@ PackageCheckout subclass: GitPackageCheckout [ | realUrl command saveDir | self checkoutDirectory exists ifFalse: [ - self checkoutDirectory emitMkdir. + self checkoutDirectory emitMkdir. realUrl := url copy. url scheme ~ 'git+(https?|rsync)' ifTrue: [ realUrl scheme: (url scheme copyFrom: 5) ]. url host = '' ifTrue: [ realUrl := realUrl path ]. - command := 'git clone --depth 1 %1 .' % {realUrl} ] + command := 'git clone --depth 1 %1 .' % {realUrl} ] ifTrue: [ command := 'git fetch' ]. @@ -265,7 +265,7 @@ PackageCheckout subclass: GitPackageCheckout [ saveDir := Directory working. Command execute: [ - Directory working: self checkoutDirectory. + Directory working: self checkoutDirectory. Smalltalk system: command ] ensure: [ Directory working: saveDir ]. @@ -274,10 +274,10 @@ PackageCheckout subclass: GitPackageCheckout [ ('cd %1 && ' % { self checkoutDirectory }, command) displayNl. Command - execute: [ - Directory working: self checkoutDirectory. + execute: [ + Directory working: self checkoutDirectory. Smalltalk system: command ] - ensure: [ Directory working: saveDir ] ] + ensure: [ Directory working: saveDir ] ] ] ] @@ -326,7 +326,7 @@ Kernel.PackageDirectories subclass: PackageFiles [ package packages do: [ :each | (each url notNil and: [each url notEmpty]) ifTrue: [ found := true. - each url = urlString ifTrue: [ + each url = urlString ifTrue: [ ^self error: 'infinite loop in package.xml urls' ]. self addURL: (NetClients.URL fromString: each url) ]]. found ifTrue: [^self]. @@ -381,7 +381,7 @@ File extend [ saveDir := Directory working. Command execute: [ - Directory working: dir name. + Directory working: dir name. Smalltalk system: '%1 -n .st:.xml -qr %2 .' % { Command zip. self } ] ensure: [ Directory working: saveDir ] @@ -411,10 +411,10 @@ File extend [ displayNl. Command execute: [ - destFile exists ifTrue: [ destFile remove ]. - srcStream := self readStream. + destFile exists ifTrue: [ destFile remove ]. + srcStream := self readStream. destStream := destFile writeStream. - destStream nextPutAll: srcStream. + destStream nextPutAll: srcStream. ] ensure: [ destStream isNil ifFalse: [ destStream close ]. @@ -467,7 +467,7 @@ Object subclass: Command [ optionsCollection := OrderedCollection new. options keysDo: [ :opt | (options at: opt) do: [ :arg | - optionsCollection add: opt->arg ]]. + optionsCollection add: opt->arg ]]. ^optionsCollection ] @@ -475,9 +475,9 @@ Object subclass: Command [ options := Dictionary new. aCollection do: [ :assoc | (options at: assoc key ifAbsentPut: [ OrderedCollection new ]) - addLast: assoc value. + addLast: assoc value. (self isValidOption: assoc key) ifFalse: [ - self error: ('--%1 invalid for this mode' % {assoc key}) ] ] + self error: ('--%1 invalid for this mode' % {assoc key}) ] ] ] isValidOption: aString [ @@ -753,19 +753,19 @@ PackageCommand subclass: PkgInstall [ baseDir emitMkdir. Command execute: [ - (baseDir / 'package.xml') withWriteStreamDo: [ :s | - pkg printOn: s ]. + (baseDir / 'package.xml') withWriteStreamDo: [ :s | + pkg printOn: s ]. - files := pkg allFiles. + files := pkg allFiles. dirs := files collect: [ :file | File pathFor: file ]. - (dirs asSet remove: '' ifAbsent: []; asSortedCollection) + (dirs asSet remove: '' ifAbsent: []; asSortedCollection) do: [ :dir | (baseDir / dir) emitMkdir ]. files do: [ :file || srcFile | - srcFile := (aPackage fullPathOf: file). - srcFile emitSymlink: (baseDir nameAt: file) ]. + srcFile := (aPackage fullPathOf: file). + srcFile emitSymlink: (baseDir nameAt: file) ]. - (self installDir / aPackage name, '.star') + (self installDir / aPackage name, '.star') emitZipDir: baseDir ] ensure: [ baseDir all remove ]. @@ -811,6 +811,30 @@ PackageCommand subclass: ListCommand [ defaultInstallDir [ ^'.' ] ] +ListCommand subclass: PckRepositoryList [ + PckRepositoryList class >> selectionOptions [ + <category: 'accessing'> + + ^ #('list-repository') + ] + + run [ + <category: 'execution'> + + "stream := '/home/gwenael/Temp/repository.xml' asFile readStream." + 'Packages list : ' displayNl. + (Kernel.PackageRepository parse: (NetClients.URL fromString: 'http://smalltalk.gnu.org/project/repository.xml') readStream) + packagesDo: [ :each | + each displayNl ] + ] + + executeOnAll: args [ + <category: 'execution'> + + self run + ] +] + ListCommand subclass: PkgList [ PkgList class >> selectionOptions [ ^#('list-files' 'no-install') @@ -885,11 +909,11 @@ PackageCommand subclass: PkgPrepare [ srcFile isNil ifTrue: [ f := self srcdir / aString. (File exists: f) - ifTrue: [ srcFile := (File name: self srcdir) pathTo: f ]. + ifTrue: [ srcFile := (File name: self srcdir) pathTo: f ]. f := f, '.in'. (File exists: f) - ifTrue: [ srcFile := (File name: self srcdir) pathTo: f ]. + ifTrue: [ srcFile := (File name: self srcdir) pathTo: f ]. (File exists: aString) ifTrue: [ srcFile := File name: aString ]. @@ -910,15 +934,15 @@ PackageCommand subclass: PkgPrepare [ configureAC exists ifFalse: [ 'creating configure.ac' displayNl. Command dryRun ifFalse: [ - configureAC withWriteStreamDo: [ :ws | self writeConfigure: ws ] ] ]. + configureAC withWriteStreamDo: [ :ws | self writeConfigure: ws ] ] ]. gstIN exists ifFalse: [ 'creating gst.in' displayNl. Command dryRun ifFalse: [ - gstIN withWriteStreamDo: [ :ws | self writeGstIn: ws ] ] ]. + gstIN withWriteStreamDo: [ :ws | self writeGstIn: ws ] ] ]. makefileAM exists ifFalse: [ 'creating Makefile.am' displayNl. Command dryRun ifFalse: [ - makefileAM withWriteStreamDo: [ :ws | self writeMakefile: ws ] ] ] + makefileAM withWriteStreamDo: [ :ws | self writeMakefile: ws ] ] ] ] writeGstIn: ws [ @@ -984,8 +1008,8 @@ AC_OUTPUT (File name: each) withReadStreamDo: [ :rs | | pkg | [ pkg := Package parse: rs ] - on: Kernel.PackageNotAvailable - do: [ :ex | ex resume ]. + on: Kernel.PackageNotAvailable + do: [ :ex | ex resume ]. pkgName := pkg name ]. ws nextPutAll: ('GST_PACKAGE_ENABLE([%1], [%2]' % { @@ -1043,7 +1067,7 @@ Object subclass: PackageManager [ ModeClasses isNil ifTrue: [ ModeClasses := Dictionary new. Command allSubclassesDo: [ :each | - each selectionOptions do: [ :opt | + each selectionOptions do: [ :opt | ModeClasses at: opt put: each ] ] ]. ^ModeClasses @@ -1085,6 +1109,7 @@ Operation modes: --prepare create configure.ac or Makefile.am --list-files PKG just output the list of files in the package --list-packages just output the list of packages in the files + --list-repository just output the list of packages in the repository smalltalk.gnu.org --download, --update download package from smalltalk.gnu.org or from its specified URL @@ -1095,8 +1120,8 @@ Operation modes: Common suboptions: -n, --dry-run print commands without running them --srcdir DIR look for non-built files in directory DIR - --distdir DIR for --dist, place files in directory DIR - --destdir DIR prefix the destination directory with DIR + --distdir DIR for --dist, place files in directory DIR + --destdir DIR prefix the destination directory with DIR --target-directory DIR install the files in DIR (unused for --dist) -I, --image-file=FILE load into the specified image --kernel-dir=PATH use the specified kernel directory @@ -1144,16 +1169,16 @@ The default target directory is ', Directory image name, ' default. --no-install is also present for backwards compatibility." parse: args with: '-h|--help --no-load --test --load --no-install --uninstall - --dist -t|--target-directory: --list-files: --list-packages + --dist -t|--target-directory: --list-files: --list-packages --list-repository --prepare --srcdir: --distdir|--destdir: -n|--dry-run --all-files --vpath --copy -I|--image-file: --kernel-directory: --update|--download --version' do: [ :opt :arg || modeClass | - opt = 'help' ifTrue: [ + opt = 'help' ifTrue: [ self displayHelpAndQuit: 0 ]. - opt = 'version' ifTrue: [ + opt = 'version' ifTrue: [ ('gst-package - %1' % {Smalltalk version}) displayNl. ObjectMemory quit: 0 ].
_______________________________________________ help-smalltalk mailing list [email protected] http://lists.gnu.org/mailman/listinfo/help-smalltalk
