Importer-Exporter.st 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384
  1. Smalltalk current createPackage: 'Importer-Exporter' properties: #{}!
  2. Object subclass: #ChunkParser
  3. instanceVariableNames: 'stream'
  4. package: 'Importer-Exporter'!
  5. !ChunkParser methodsFor: 'accessing'!
  6. stream: aStream
  7. stream := aStream
  8. ! !
  9. !ChunkParser methodsFor: 'reading'!
  10. nextChunk
  11. "The chunk format (Smalltalk Interchange Format or Fileout format)
  12. is a trivial format but can be a bit tricky to understand:
  13. - Uses the exclamation mark as delimiter of chunks.
  14. - Inside a chunk a normal exclamation mark must be doubled.
  15. - A non empty chunk must be a valid Smalltalk expression.
  16. - A chunk on top level with a preceding empty chunk is an instruction chunk:
  17. - The object created by the expression then takes over reading chunks.
  18. This metod returns next chunk as a String (trimmed), empty String (all whitespace) or nil."
  19. | char result chunk |
  20. result := '' writeStream.
  21. [char := stream next.
  22. char notNil] whileTrue: [
  23. char = '!!' ifTrue: [
  24. stream peek = '!!'
  25. ifTrue: [stream next "skipping the escape double"]
  26. ifFalse: [^result contents trimBoth "chunk end marker found"]].
  27. result nextPut: char].
  28. ^nil "a chunk needs to end with !!"
  29. ! !
  30. !ChunkParser class methodsFor: 'not yet classified'!
  31. on: aStream
  32. ^self new stream: aStream
  33. ! !
  34. Object subclass: #Exporter
  35. instanceVariableNames: ''
  36. package: 'Importer-Exporter'!
  37. !Exporter methodsFor: 'fileOut'!
  38. exportAll
  39. "Export all packages in the system."
  40. ^String streamContents: [:stream |
  41. Smalltalk current packages do: [:pkg |
  42. stream nextPutAll: (self exportPackage: pkg name)]]
  43. !
  44. exportClass: aClass
  45. "Export a single class. Subclasses override these methods."
  46. ^String streamContents: [:stream |
  47. self exportDefinitionOf: aClass on: stream.
  48. self exportMethodsOf: aClass on: stream.
  49. self exportMetaDefinitionOf: aClass on: stream.
  50. self exportMethodsOf: aClass class on: stream]
  51. !
  52. exportPackage: packageName
  53. "Export a given package by name."
  54. | package |
  55. ^String streamContents: [:stream |
  56. package := Smalltalk current packageAt: packageName.
  57. self exportPackageDefinitionOf: package on: stream.
  58. "Export classes in dependency order.
  59. Update (issue #171): Remove duplicates for export"
  60. package sortedClasses asSet do: [:each |
  61. stream nextPutAll: (self exportClass: each)].
  62. self exportPackageExtensionsOf: package on: stream]
  63. ! !
  64. !Exporter methodsFor: 'private'!
  65. classNameFor: aClass
  66. ^aClass isMetaclass
  67. ifTrue: [aClass instanceClass name, '.klass']
  68. ifFalse: [
  69. aClass isNil
  70. ifTrue: ['nil']
  71. ifFalse: [aClass name]]
  72. !
  73. exportDefinitionOf: aClass on: aStream
  74. aStream
  75. nextPutAll: 'smalltalk.addClass(';
  76. nextPutAll: '''', (self classNameFor: aClass), ''', ';
  77. nextPutAll: 'smalltalk.', (self classNameFor: aClass superclass);
  78. nextPutAll: ', ['.
  79. aClass instanceVariableNames
  80. do: [:each | aStream nextPutAll: '''', each, '''']
  81. separatedBy: [aStream nextPutAll: ', '].
  82. aStream
  83. nextPutAll: '], ''';
  84. nextPutAll: aClass category, '''';
  85. nextPutAll: ');'.
  86. aClass comment notEmpty ifTrue: [
  87. aStream
  88. lf;
  89. nextPutAll: 'smalltalk.';
  90. nextPutAll: (self classNameFor: aClass);
  91. nextPutAll: '.comment=';
  92. nextPutAll: aClass comment asJavascript].
  93. aStream lf
  94. !
  95. exportMetaDefinitionOf: aClass on: aStream
  96. aClass class instanceVariableNames isEmpty ifFalse: [
  97. aStream
  98. nextPutAll: 'smalltalk.', (self classNameFor: aClass class);
  99. nextPutAll: '.iVarNames = ['.
  100. aClass class instanceVariableNames
  101. do: [:each | aStream nextPutAll: '''', each, '''']
  102. separatedBy: [aStream nextPutAll: ','].
  103. aStream nextPutAll: '];', String lf]
  104. !
  105. exportMethod: aMethod of: aClass on: aStream
  106. aStream
  107. nextPutAll: 'smalltalk.addMethod(';lf;
  108. nextPutAll: aMethod selector asSelector asJavascript, ',';lf;
  109. nextPutAll: 'smalltalk.method({';lf;
  110. nextPutAll: 'selector: ', aMethod selector asJavascript, ',';lf;
  111. nextPutAll: 'category: ''', aMethod category, ''',';lf;
  112. nextPutAll: 'fn: ', aMethod fn compiledSource, ',';lf;
  113. nextPutAll: 'args: ', aMethod arguments asJavascript, ','; lf;
  114. nextPutAll: 'source: ', aMethod source asJavascript, ',';lf;
  115. nextPutAll: 'messageSends: ', aMethod messageSends asJavascript, ',';lf;
  116. nextPutAll: 'referencedClasses: ', aMethod referencedClasses asJavascript.
  117. aStream
  118. lf;
  119. nextPutAll: '}),';lf;
  120. nextPutAll: 'smalltalk.', (self classNameFor: aClass);
  121. nextPutAll: ');';lf;lf
  122. !
  123. exportMethodsOf: aClass on: aStream
  124. "Issue #143: sort methods alphabetically"
  125. ((aClass methodDictionary values) sorted: [:a :b | a selector <= b selector]) do: [:each |
  126. (each category match: '^\*') ifFalse: [
  127. self exportMethod: each of: aClass on: aStream]].
  128. aStream lf
  129. !
  130. exportPackageDefinitionOf: package on: aStream
  131. aStream
  132. nextPutAll: 'smalltalk.addPackage(';
  133. nextPutAll: '''', package name, ''', ', package propertiesAsJSON , ');'.
  134. aStream lf
  135. !
  136. exportPackageExtensionsOf: package on: aStream
  137. "Issue #143: sort classes and methods alphabetically"
  138. | name |
  139. name := package name.
  140. (Package sortedClasses: Smalltalk current classes) do: [:each |
  141. {each. each class} do: [:aClass |
  142. ((aClass methodDictionary values) sorted: [:a :b | a selector <= b selector]) do: [:method |
  143. (method category match: '^\*', name) ifTrue: [
  144. self exportMethod: method of: aClass on: aStream ]]]]
  145. ! !
  146. Exporter subclass: #ChunkExporter
  147. instanceVariableNames: ''
  148. package: 'Importer-Exporter'!
  149. !ChunkExporter methodsFor: 'not yet classified'!
  150. chunkEscape: aString
  151. "Replace all occurrences of !! with !!!! and trim at both ends."
  152. ^(aString replace: '!!' with: '!!!!') trimBoth
  153. !
  154. classNameFor: aClass
  155. ^aClass isMetaclass
  156. ifTrue: [aClass instanceClass name, ' class']
  157. ifFalse: [
  158. aClass isNil
  159. ifTrue: ['nil']
  160. ifFalse: [aClass name]]
  161. !
  162. exportDefinitionOf: aClass on: aStream
  163. "Chunk format."
  164. aStream
  165. nextPutAll: (self classNameFor: aClass superclass);
  166. nextPutAll: ' subclass: #', (self classNameFor: aClass); lf;
  167. nextPutAll: ' instanceVariableNames: '''.
  168. aClass instanceVariableNames
  169. do: [:each | aStream nextPutAll: each]
  170. separatedBy: [aStream nextPutAll: ' '].
  171. aStream
  172. nextPutAll: ''''; lf;
  173. nextPutAll: ' package: ''', aClass category, '''!!'; lf.
  174. aClass comment notEmpty ifTrue: [
  175. aStream
  176. nextPutAll: '!!', (self classNameFor: aClass), ' commentStamp!!';lf;
  177. nextPutAll: (self chunkEscape: aClass comment), '!!';lf].
  178. aStream lf
  179. !
  180. exportMetaDefinitionOf: aClass on: aStream
  181. aClass class instanceVariableNames isEmpty ifFalse: [
  182. aStream
  183. nextPutAll: (self classNameFor: aClass class);
  184. nextPutAll: ' instanceVariableNames: '''.
  185. aClass class instanceVariableNames
  186. do: [:each | aStream nextPutAll: each]
  187. separatedBy: [aStream nextPutAll: ' '].
  188. aStream
  189. nextPutAll: '''!!'; lf; lf]
  190. !
  191. exportMethod: aMethod of: aClass on: aStream
  192. aStream
  193. lf; lf; nextPutAll: (self chunkEscape: aMethod source); lf;
  194. nextPutAll: '!!'
  195. !
  196. exportMethods: methods category: category of: aClass on: aStream
  197. "Issue #143: sort methods alphabetically"
  198. aStream
  199. nextPutAll: '!!', (self classNameFor: aClass);
  200. nextPutAll: ' methodsFor: ''', category, '''!!'.
  201. (methods sorted: [:a :b | a selector <= b selector]) do: [:each |
  202. self exportMethod: each of: aClass on: aStream].
  203. aStream nextPutAll: ' !!'; lf; lf
  204. !
  205. exportMethodsOf: aClass on: aStream
  206. "Issue #143: sort protocol alphabetically"
  207. | map |
  208. map := Dictionary new.
  209. aClass protocolsDo: [:category :methods |
  210. (category match: '^\*') ifFalse: [ map at: category put: methods ]].
  211. (map keys sorted: [:a :b | a <= b ]) do: [:category | | methods |
  212. methods := map at: category.
  213. self
  214. exportMethods: methods
  215. category: category
  216. of: aClass
  217. on: aStream ]
  218. !
  219. exportPackageDefinitionOf: package on: aStream
  220. "Chunk format."
  221. aStream
  222. nextPutAll: 'Smalltalk current createPackage: ''', package name,
  223. ''' properties: ', package properties storeString, '!!'; lf.
  224. !
  225. exportPackageExtensionsOf: package on: aStream
  226. "We need to override this one too since we need to group
  227. all methods in a given protocol under a leading methodsFor: chunk
  228. for that class."
  229. "Issue #143: sort protocol alphabetically"
  230. | name map |
  231. name := package name.
  232. (Package sortedClasses: Smalltalk current classes) do: [:each |
  233. {each. each class} do: [:aClass |
  234. map := Dictionary new.
  235. aClass protocolsDo: [:category :methods |
  236. (category match: '^\*', name) ifTrue: [ map at: category put: methods ]].
  237. (map keys sorted: [:a :b | a <= b ]) do: [:category | | methods |
  238. methods := map at: category.
  239. self exportMethods: methods category: category of: aClass on: aStream ]]]
  240. ! !
  241. Exporter subclass: #StrippedExporter
  242. instanceVariableNames: ''
  243. package: 'Importer-Exporter'!
  244. !StrippedExporter methodsFor: 'private'!
  245. exportDefinitionOf: aClass on: aStream
  246. aStream
  247. nextPutAll: 'smalltalk.addClass(';
  248. nextPutAll: '''', (self classNameFor: aClass), ''', ';
  249. nextPutAll: 'smalltalk.', (self classNameFor: aClass superclass);
  250. nextPutAll: ', ['.
  251. aClass instanceVariableNames
  252. do: [:each | aStream nextPutAll: '''', each, '''']
  253. separatedBy: [aStream nextPutAll: ', '].
  254. aStream
  255. nextPutAll: '], ''';
  256. nextPutAll: aClass category, '''';
  257. nextPutAll: ');'.
  258. aStream lf
  259. !
  260. exportMethod: aMethod of: aClass on: aStream
  261. aStream
  262. nextPutAll: 'smalltalk.addMethod(';lf;
  263. nextPutAll: aMethod selector asSelector asJavascript, ',';lf;
  264. nextPutAll: 'smalltalk.method({';lf;
  265. nextPutAll: 'selector: ', aMethod selector asJavascript, ',';lf;
  266. nextPutAll: 'fn: ', aMethod fn compiledSource, ',';lf;
  267. nextPutAll: 'messageSends: ', aMethod messageSends asJavascript;
  268. nextPutAll: '}),';lf;
  269. nextPutAll: 'smalltalk.', (self classNameFor: aClass);
  270. nextPutAll: ');';lf;lf
  271. ! !
  272. Object subclass: #Importer
  273. instanceVariableNames: ''
  274. package: 'Importer-Exporter'!
  275. !Importer methodsFor: 'fileIn'!
  276. import: aStream
  277. | chunk result parser lastEmpty |
  278. parser := ChunkParser on: aStream.
  279. lastEmpty := false.
  280. [chunk := parser nextChunk.
  281. chunk isNil] whileFalse: [
  282. chunk isEmpty
  283. ifTrue: [lastEmpty := true]
  284. ifFalse: [
  285. result := Compiler new evaluateExpression: chunk.
  286. lastEmpty
  287. ifTrue: [
  288. lastEmpty := false.
  289. result scanFrom: parser]]]
  290. ! !
  291. Object subclass: #PackageLoader
  292. instanceVariableNames: ''
  293. package: 'Importer-Exporter'!
  294. !PackageLoader methodsFor: 'laoding'!
  295. initializePackageNamed: packageName prefix: aString
  296. (Package named: packageName)
  297. setupClasses;
  298. commitPathJs: '/', aString, '/js';
  299. commitPathSt: '/', aString, '/st'
  300. !
  301. loadPackage: packageName prefix: aString
  302. | url |
  303. url := '/', aString, '/js/', packageName, '.js'.
  304. jQuery
  305. ajax: url
  306. options: #{
  307. 'type' -> 'GET'.
  308. 'dataType' -> 'script'.
  309. 'complete' -> [ :jqXHR :textStatus |
  310. jqXHR readyState = 4
  311. ifTrue: [ self initializePackageNamed: packageName prefix: aString ] ].
  312. 'error' -> [ window alert: 'Could not load package at: ', url ]
  313. }
  314. !
  315. loadPackages: aCollection prefix: aString
  316. aCollection do: [ :each |
  317. self loadPackage: each prefix: aString ]
  318. ! !
  319. !PackageLoader class methodsFor: 'not yet classified'!
  320. loadPackages: aCollection prefix: aString
  321. ^ self new loadPackages: aCollection prefix: aString
  322. ! !