http/ahah.st

   1 "
   2  coded by Ketmar // Vampire Avalon (psyc://ketmar.no-ip.org/~Ketmar)
   3  Understanding is not required. Only obedience.
   4
   5  This program is free software. It comes without any warranty, to
   6  the extent permitted by applicable law. You can redistribute it
   7  and/or modify it under the terms of the Do What The Fuck You Want
   8  To Public License, Version 2, as published by Sam Hocevar. See
   9  http://sam.zoy.org/wtfpl/COPYING for more details.
  10 "
  11 Requires [ httpsvx ]
  12
  13 Package [
  14   HttpClassBrowser
  15 ]
  16
  17
  18 HttpHandler subclass: HttpHandlerAhah [
  19   emitPackages [
  20     Package packages keysDo: [:obj | self emit: obj asString; emit: '\n' ].
  21   ]
  22
  23   emitClasses [
  24     | pkg |
  25     (pkg := req var: #package) ifNotNil: [ pkg := Package find: pkg asSymbol ].
  26     pkg ifNotNil: [ pkg := pkg classes ] ifNil: [ pkg := globals ].
  27     pkg do: [:obj | (obj isKindOf: Class) ifTrue: [
  28       obj isMeta ifFalse: [ self emit: obj asString; emit: '\n'. ]
  29     ]].
  30   ]
  31
  32   emitMethods [
  33     | cls |
  34     (cls := req var: #class) ifNotNil: [ cls := globals at: (cls asSymbol) ifAbsent: [ nil ]].
  35     cls ifNotNil: [
  36       cls class methods do: [:mth | self emit: '^'; emit: mth name asString; emit: '\n' ].
  37       cls methods do: [:mth | self emit: mth name asString; emit: '\n' ].
  38     ].
  39   ]
  40
  41   emitSource [
  42     | cls mth isMeta |
  43     (mth := req var: #srctext ifAbsent: ['']) = '' ifTrue: [
  44       ((cls := req var: #class) ifNotNil: [ cls := globals at: (cls asSymbol) ifAbsent: [ nil ]]) ifNotNil: [
  45         (mth := req var: #method) ifNotNil: [
  46           mth firstChar == $^ ifTrue: [ mth := mth from: 2. cls := cls class. isMeta := '^' ] ifFalse: [ isMeta := '' ].
  47           (mth := cls findMethodInAll: mth asSymbol ifAbsent: [ nil ]) ifNotNil: [
  48             self emit: isMeta; emit: mth text.
  49           ]
  50         ]
  51       ]
  52     ].
  53   ]
  54
  55   compileMethod [
  56     | mth cls p txt isMeta |
  57     (txt := (req var: #srctext ifAbsent: ['']) removeTrailingBlanks) = '' ifTrue: [
  58       ^self emit: 'ERROR: nothing to compile!'.
  59     ].
  60     ((cls := req var: #class) ifNotNil: [ cls := globals at: (cls asSymbol) ifAbsent: [ nil ]]) ifNil: [
  61       ^self emit: 'ERROR: no class selected!'.
  62     ].
  63     txt := txt reject: [ :c | c isCR ].
  64     "compile and add method"
  65     p := LstCompiler new.
  66     p errorBlock: [ :msg :lineNum |
  67       ^self emit: 'ERROR near line ' + lineNum asString + ': ' + msg htmlEscape + '\n'.
  68     ].
  69     p warningBlock: [ :msg :lineNum |
  70       self emit: 'WARNING near line ' + lineNum asString + ': ' + msg htmlEscape + '\n'.
  71     ].
  72     (mth := (cls addMethod: txt withCompiler: p)) ifNotNil: [
  73       isMeta := txt firstNonBlankChar == $^.
  74       p := cls asString + '>>'+ (isMeta ifTrue: ['^'] ifFalse: ['']) + mth name asString.
  75       self emit: 'SUCCESS: method ' + p + ' succcesfully compiled.\n'
  76     ].
  77   ]
  78
  79   emitBody [
  80     ctype := 'text/plain'.
  81     self set2xx.
  82     req file = 'package' ifTrue: [ ^self emitPackages ].
  83     req file = 'class' ifTrue: [ ^self emitClasses ].
  84     req file = 'method' ifTrue: [ ^self emitMethods ].
  85     req file = 'srctext' ifTrue: [ ^self emitSource ].
  86     req file = 'compile' ifTrue: [ ^self compileMethod ].
  87     ^super emitBody
  88   ]
  89 ]