Consolidated ASP Classic MVC framework from best components
Vous ne pouvez pas sélectionner plus de 25 sujets Les noms de sujets doivent commencer par une lettre ou un nombre, peuvent contenir des tirets ('-') et peuvent comporter jusqu'à 35 caractères.

638 lignes
27KB

  1. '==============================================================
  2. ' GeneratePOBOAndRepository.vbs
  3. '
  4. ' Usage:
  5. ' cscript //nologo GeneratePOBOAndRepository.vbs /table:Orders /pk:OrderID [/cs:MyConnString] [/config:C:\path\web.config]
  6. '
  7. ' Reads connection string from web.config <appSettings>,
  8. ' discovers [table] schema, and generates:
  9. ' � POBO_<Table>.asp (Classic ASP class with typed Property Lets)
  10. ' � <Table>Repository.asp (parameterized CRUD + paging + search)
  11. '
  12. ' Safe for Access or SQL Server connection strings.
  13. '==============================================================
  14. Option Explicit
  15. '---------------- Args & paths ----------------
  16. Dim fso, args, i, arg, parts
  17. Dim tableName, primaryKey, csKey, configPath, thisFolder
  18. Set fso = CreateObject("Scripting.FileSystemObject")
  19. Set args = WScript.Arguments
  20. csKey = "ConnectionString"
  21. thisFolder = fso.GetParentFolderName(WScript.ScriptFullName)
  22. configPath = fso.GetParentFolderName(fso.GetParentFolderName(WScript.ScriptFullName)) & "\public\web.config"
  23. For i = 0 To args.Count - 1
  24. arg = args(i)
  25. If InStr(arg, ":") > 0 Then
  26. parts = Split(arg, ":", 2)
  27. Select Case LCase(Replace(parts(0), "/", ""))
  28. Case "table": tableName = parts(1)
  29. Case "pk": primaryKey = parts(1)
  30. Case "cs": csKey = parts(1)
  31. Case "config": configPath = parts(1)
  32. End Select
  33. End If
  34. Next
  35. If Len(tableName) = 0 Or Len(primaryKey) = 0 Then
  36. WScript.Echo "Usage: cscript //nologo GeneratePOBOAndRepository.vbs /table:<TableName> /pk:<PrimaryKey> [/cs:<ConnStringKey>] [/config:<PathToWebConfig>]"
  37. WScript.Quit 1
  38. End If
  39. ' Validate table name format (alphanumeric, underscore only - prevent SQL injection)
  40. If Not IsValidIdentifier(tableName) Then
  41. WScript.Echo "Error: Invalid table name format. Only letters, numbers, and underscores are allowed."
  42. WScript.Quit 1
  43. End If
  44. ' Validate primary key format
  45. If Not IsValidIdentifier(primaryKey) Then
  46. WScript.Echo "Error: Invalid primary key format. Only letters, numbers, and underscores are allowed."
  47. WScript.Quit 1
  48. End If
  49. '---------------- Config & connection ----------------
  50. Dim connStr
  51. connStr = GetAppSetting(csKey, configPath)
  52. If connStr = "nothing" Then
  53. WScript.Echo "Error: Key '" & csKey & "' not found in " & configPath
  54. WScript.Quit 1
  55. End If
  56. Dim conn
  57. Set conn = CreateObject("ADODB.Connection")
  58. On Error Resume Next
  59. conn.Open connStr
  60. If Err.Number <> 0 Then
  61. WScript.Echo "DB connection failed: " & Err.Description
  62. WScript.Quit 1
  63. End If
  64. On Error GoTo 0
  65. '---------------- Discover schema (portable) ----------------
  66. ' Strategy:
  67. ' 1) Try OpenSchema(adSchemaColumns) for rich metadata.
  68. ' 2) Fallback to "SELECT * WHERE 1=0" to at least get names/types.
  69. Const adSchemaColumns = 4
  70. Dim cols(), types(), nullable(), ordinals(), fld, idx
  71. Dim haveSchema : haveSchema = False
  72. On Error Resume Next
  73. Dim rsCols
  74. Set rsCols = conn.OpenSchema(adSchemaColumns, Array(Empty, Empty, tableName, Empty))
  75. If Err.Number = 0 Then
  76. idx = -1
  77. Do Until rsCols.EOF
  78. idx = idx + 1
  79. ReDim Preserve cols(idx), types(idx), nullable(idx), ordinals(idx)
  80. cols(idx) = CStr(rsCols("COLUMN_NAME"))
  81. types(idx) = Nz(rsCols("DATA_TYPE"), 0) ' ADO type enum
  82. nullable(idx) = LCase(CStr(Nz(rsCols("IS_NULLABLE"), "YES"))) = "yes"
  83. ordinals(idx) = CLng(Nz(rsCols("ORDINAL_POSITION"), idx+1))
  84. rsCols.MoveNext
  85. Loop
  86. rsCols.Close : Set rsCols = Nothing
  87. haveSchema = (idx >= 0)
  88. Else
  89. Err.Clear
  90. End If
  91. On Error GoTo 0
  92. If Not haveSchema Then
  93. ' Fallback: get names/types from zero-row select
  94. On Error Resume Next
  95. Dim rsProbe
  96. Set rsProbe = conn.Execute("SELECT * FROM " & QI(tableName) & " WHERE 1=0")
  97. If Err.Number <> 0 Then
  98. WScript.Echo "Error querying table [" & tableName & "]: " & Err.Description
  99. conn.Close : Set conn = Nothing
  100. WScript.Quit 1
  101. End If
  102. On Error GoTo 0
  103. idx = -1
  104. For Each fld In rsProbe.Fields
  105. idx = idx + 1
  106. ReDim Preserve cols(idx), types(idx), nullable(idx), ordinals(idx)
  107. cols(idx) = fld.Name
  108. types(idx) = fld.Type
  109. nullable(idx) = True ' Unknown; assume nullable
  110. ordinals(idx) = idx + 1
  111. Next
  112. rsProbe.Close : Set rsProbe = Nothing
  113. End If
  114. If idx < 0 Then
  115. WScript.Echo "No columns found for table [" & tableName & "]."
  116. WScript.Quit 1
  117. End If
  118. ' Sort metadata by ordinal (defensive)
  119. Call ArraySortByParallel(ordinals, Array(cols, types, nullable))
  120. ' Validate PK exists
  121. If Not InArrayInsensitive(cols, primaryKey) Then
  122. WScript.Echo "Primary key '" & primaryKey & "' not found in table [" & tableName & "]."
  123. WScript.Quit 1
  124. End If
  125. '---------------- Generate POBO_<Table>.asp ----------------
  126. Dim poboOut
  127. poboOut = BuildPOBO(cols, types, tableName, primaryKey)
  128. Dim poboPath, tf
  129. poboPath = fso.BuildPath(thisFolder, "POBO_" & tableName & ".asp")
  130. Set tf = fso.CreateTextFile(poboPath, True, False)
  131. tf.Write poboOut
  132. tf.Close
  133. Set tf = Nothing
  134. WScript.Echo "POBO class written to: " & poboPath
  135. '---------------- Generate <Table>Repository.asp ----------------
  136. Dim repoOut
  137. repoOut = BuildRepository(cols, tableName, primaryKey)
  138. Dim repoPath
  139. repoPath = fso.BuildPath(thisFolder, tableName & "Repository.asp")
  140. Set tf = fso.CreateTextFile(repoPath, True, False)
  141. tf.Write repoOut
  142. tf.Close
  143. Set tf = Nothing
  144. WScript.Echo "Repository written to: " & repoPath
  145. '---------------- Cleanup ----------------
  146. conn.Close : Set conn = Nothing
  147. Set fso = Nothing
  148. '==============================================================
  149. ' POBO generator (your example, integrated)
  150. '==============================================================
  151. Function BuildPOBO(byRef colsArr, byRef typesArr, ByVal tName, ByVal pk)
  152. Dim classDef, idxLocal, name, ftype
  153. Dim parts()
  154. ReDim parts(1000) ' Pre-allocate for performance
  155. Dim partIdx : partIdx = 0
  156. ' Build using array for performance (StringBuilder pattern)
  157. parts(partIdx) = "<%" & vbCrLf : partIdx = partIdx + 1
  158. parts(partIdx) = "' Auto-generated POBO for table [" & tName & "]" & vbCrLf : partIdx = partIdx + 1
  159. parts(partIdx) = "' Generated on " & Now() & vbCrLf : partIdx = partIdx + 1
  160. parts(partIdx) = "' Generator: GenerateRepo.vbs v1.0" & vbCrLf : partIdx = partIdx + 1
  161. parts(partIdx) = "'" & vbCrLf : partIdx = partIdx + 1
  162. parts(partIdx) = "' Dependencies: core/helpers.asp (QuoteValue function)" & vbCrLf : partIdx = partIdx + 1
  163. parts(partIdx) = vbCrLf & vbCrLf : partIdx = partIdx + 1
  164. parts(partIdx) = "Class POBO_" & tName & vbCrLf : partIdx = partIdx + 1
  165. parts(partIdx) = " ' Public array of all property names" & vbCrLf : partIdx = partIdx + 1
  166. parts(partIdx) = " Public Properties" & vbCrLf & vbCrLf : partIdx = partIdx + 1
  167. ' Private backing fields
  168. For idxLocal = 0 To UBound(colsArr)
  169. parts(partIdx) = " Private p" & colsArr(idxLocal) & vbCrLf : partIdx = partIdx + 1
  170. Next
  171. ' Initializer with defaults
  172. parts(partIdx) = vbCrLf & " Private Sub Class_Initialize()" & vbCrLf : partIdx = partIdx + 1
  173. For idxLocal = 0 To UBound(colsArr)
  174. Select Case typesArr(idxLocal)
  175. Case 200,201,202,203 ' adChar, adVarChar, adVarWChar, adWChar (strings)
  176. parts(partIdx) = " p" & colsArr(idxLocal) & " = """"" & vbCrLf : partIdx = partIdx + 1
  177. Case 7,133,135 ' adDate, adDBDate, adDBTimeStamp (dates)
  178. parts(partIdx) = " p" & colsArr(idxLocal) & " = #1/1/1970#" & vbCrLf : partIdx = partIdx + 1
  179. Case 2,3,4,5,6,14,131 ' adSmallInt, adInteger, adSingle, adDouble, adCurrency, adDecimal, adNumeric
  180. parts(partIdx) = " p" & colsArr(idxLocal) & " = 0" & vbCrLf : partIdx = partIdx + 1
  181. Case 11 ' adBoolean
  182. parts(partIdx) = " p" & colsArr(idxLocal) & " = False" & vbCrLf : partIdx = partIdx + 1
  183. Case Else
  184. parts(partIdx) = " p" & colsArr(idxLocal) & " = Null" & vbCrLf : partIdx = partIdx + 1
  185. End Select
  186. Next
  187. parts(partIdx) = " Properties = Array(""" & Join(colsArr, """,""") & """)" & vbCrLf : partIdx = partIdx + 1
  188. parts(partIdx) = " End Sub" & vbCrLf & vbCrLf : partIdx = partIdx + 1
  189. parts(partIdx) = " Public Property Get PrimaryKey()" & vbCrLf : partIdx = partIdx + 1
  190. parts(partIdx) = " PrimaryKey = """ & pk & """" & vbCrLf : partIdx = partIdx + 1
  191. parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1
  192. parts(partIdx) = " Public Property Get TableName()" & vbCrLf : partIdx = partIdx + 1
  193. parts(partIdx) = " TableName = """ & tName & """" & vbCrLf : partIdx = partIdx + 1
  194. parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1
  195. ' Get/Let with coercion
  196. For idxLocal = 0 To UBound(colsArr)
  197. name = colsArr(idxLocal)
  198. ftype = typesArr(idxLocal)
  199. parts(partIdx) = " Public Property Get " & name & "()" & vbCrLf : partIdx = partIdx + 1
  200. parts(partIdx) = " " & name & " = p" & name & vbCrLf : partIdx = partIdx + 1
  201. parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1
  202. parts(partIdx) = " Public Property Let " & name & "(val)" & vbCrLf : partIdx = partIdx + 1
  203. parts(partIdx) = " On Error Resume Next" & vbCrLf : partIdx = partIdx + 1
  204. Select Case ftype
  205. Case 200,201,202,203 ' Strings
  206. parts(partIdx) = " p" & name & " = CStr(val)" & vbCrLf : partIdx = partIdx + 1
  207. Case 7 ' Dates
  208. parts(partIdx) = " p" & name & " = CDate(val)" & vbCrLf : partIdx = partIdx + 1
  209. Case 133,135 ' Timestamps
  210. parts(partIdx) = " p" & name & " = QuoteValue(val)" & vbCrLf : partIdx = partIdx + 1
  211. Case 11 ' Boolean
  212. parts(partIdx) = " p" & name & " = CBool(val)" & vbCrLf : partIdx = partIdx + 1
  213. Case Else ' Numeric or other
  214. parts(partIdx) = " If IsNumeric(val) Then" & vbCrLf : partIdx = partIdx + 1
  215. parts(partIdx) = " p" & name & " = CDbl(val)" & vbCrLf : partIdx = partIdx + 1
  216. parts(partIdx) = " Else" & vbCrLf : partIdx = partIdx + 1
  217. parts(partIdx) = " p" & name & " = val" & vbCrLf : partIdx = partIdx + 1
  218. parts(partIdx) = " End If" & vbCrLf : partIdx = partIdx + 1
  219. End Select
  220. parts(partIdx) = " If Err.Number <> 0 Then" & vbCrLf : partIdx = partIdx + 1
  221. parts(partIdx) = " Err.Raise Err.Number, ""POBO_" & tName & "." & name & """, ""Invalid value for " & name & ": "" & Err.Description" & vbCrLf : partIdx = partIdx + 1
  222. parts(partIdx) = " End If" & vbCrLf : partIdx = partIdx + 1
  223. parts(partIdx) = " On Error GoTo 0" & vbCrLf : partIdx = partIdx + 1
  224. parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1
  225. Next
  226. parts(partIdx) = "End Class" & vbCrLf : partIdx = partIdx + 1
  227. parts(partIdx) = "%>" & vbCrLf : partIdx = partIdx + 1
  228. ' Join array for performance
  229. ReDim Preserve parts(partIdx - 1)
  230. BuildPOBO = Join(parts, "")
  231. End Function
  232. '==============================================================
  233. ' Repository generator (parameterized; DAL.* expected)
  234. '==============================================================
  235. Function BuildRepository(byRef colsArr, ByVal tName, ByVal pk)
  236. Dim insertCols(), updateCols(), allCols(), idCol
  237. Dim iLocal, cName
  238. idCol = pk
  239. ' Copy columns (no array-to-array assignment in VBScript)
  240. ReDim allCols(UBound(colsArr))
  241. For iLocal = 0 To UBound(colsArr)
  242. allCols(iLocal) = colsArr(iLocal)
  243. Next
  244. ' Insert/Update sets: exclude PK
  245. Dim insIdx : insIdx = -1
  246. For Each cName In colsArr
  247. If Not StrEqualCI(cName, idCol) Then
  248. insIdx = insIdx + 1
  249. ReDim Preserve insertCols(insIdx)
  250. insertCols(insIdx) = cName
  251. End If
  252. Next
  253. Dim updIdx : updIdx = -1
  254. For Each cName In colsArr
  255. If Not StrEqualCI(cName, idCol) Then
  256. updIdx = updIdx + 1
  257. ReDim Preserve updateCols(updIdx)
  258. updateCols(updIdx) = cName
  259. End If
  260. Next
  261. Dim QTable, QPK, selectList, selectBase
  262. QTable = QI(tName)
  263. QPK = QI(idCol)
  264. selectList = JoinQI(allCols, ", ")
  265. selectBase = "Select " & selectList & " FROM " & QTable
  266. Dim out
  267. out = out & "<%" & vbCrLf
  268. out = out & "' Auto-generated Repository for table [" & tName & "]" & vbCrLf
  269. out = out & "' Generated on " & Now() & vbCrLf
  270. out = out & "' Generator: GenerateRepo.vbs v1.0" & vbCrLf
  271. out = out & "'" & vbCrLf
  272. out = out & "' Dependencies:" & vbCrLf
  273. out = out & "' - core/lib.DAL.asp (DAL singleton for database access)" & vbCrLf
  274. out = out & "' - core/lib.AutoMapper.asp (Automapper for object mapping)" & vbCrLf
  275. out = out & "' - core/lib.Collections.asp (LinkedList_Class)" & vbCrLf
  276. out = out & "' - core/lib.helpers.asp (KVUnzip, BuildOrderBy, QI, Destroy)" & vbCrLf
  277. out = out & vbCrLf & vbCrLf
  278. Dim className : className = tName & "Repository_Class"
  279. out = out & "Class " & className & vbCrLf & vbCrLf
  280. ' FindByID
  281. out = out & " Public Function FindByID(id)" & vbCrLf
  282. out = out & " Dim sql : sql = """ & selectBase & " WHERE " & QPK & " = ?""" & vbCrLf
  283. out = out & " Dim rs : Set rs = DAL.Query(sql, Array(id))" & vbCrLf
  284. out = out & " If rs.EOF Then" & vbCrLf
  285. out = out & " Err.Raise 1, """ & className & """, RecordNotFoundException(""" & idCol & """, id)" & vbCrLf
  286. out = out & " Else" & vbCrLf
  287. out = out & " Set FindByID = Automapper.AutoMap(rs, ""POBO_" & tName & """)" & vbCrLf
  288. out = out & " End If" & vbCrLf
  289. out = out & " Destroy rs" & vbCrLf
  290. out = out & " End Function" & vbCrLf & vbCrLf
  291. ' GetAll -> Find
  292. out = out & " Public Function GetAll(orderBy)" & vbCrLf
  293. out = out & " Set GetAll = Find(Empty, orderBy)" & vbCrLf
  294. out = out & " End Function" & vbCrLf & vbCrLf
  295. ' Find
  296. out = out & " Public Function Find(where_kvarray, order_string_or_array)" & vbCrLf
  297. out = out & " Dim sql : sql = """ & selectBase & """" & vbCrLf
  298. out = out & " Dim where_keys, where_values, i" & vbCrLf
  299. out = out & " If Not IsEmpty(where_kvarray) Then" & vbCrLf
  300. out = out & " KVUnzip where_kvarray, where_keys, where_values" & vbCrLf
  301. out = out & " If Not IsEmpty(where_keys) Then" & vbCrLf
  302. out = out & " sql = sql & "" WHERE """ & vbCrLf
  303. out = out & " For i = 0 To UBound(where_keys)" & vbCrLf
  304. out = out & " If i > 0 Then sql = sql & "" AND """ & vbCrLf
  305. out = out & " sql = sql & "" "" & QI(where_keys(i)) & "" = ?""" & vbCrLf
  306. out = out & " Next" & vbCrLf
  307. out = out & " End If" & vbCrLf
  308. out = out & " End If" & vbCrLf
  309. out = out & " sql = sql & BuildOrderBy(order_string_or_array, """ & QPK & """)" & vbCrLf
  310. out = out & " Dim rs : Set rs = DAL.Query(sql, where_values)" & vbCrLf
  311. out = out & " Dim list : Set list = new LinkedList_Class" & vbCrLf
  312. out = out & " Do Until rs.EOF" & vbCrLf
  313. out = out & " list.Push Automapper.AutoMap(rs, ""POBO_" & tName & """)" & vbCrLf
  314. out = out & " rs.MoveNext" & vbCrLf
  315. out = out & " Loop" & vbCrLf
  316. out = out & " Set Find = list" & vbCrLf
  317. out = out & " Destroy rs" & vbCrLf
  318. out = out & " End Function" & vbCrLf & vbCrLf
  319. ' FindPaged
  320. out = out & " Public Function FindPaged(where_kvarray, order_string_or_array, per_page, page_num, ByRef page_count, ByRef record_count)" & vbCrLf
  321. out = out & " Dim sql : sql = """ & selectBase & """" & vbCrLf
  322. out = out & " Dim where_keys, where_values, i" & vbCrLf
  323. out = out & " If Not IsEmpty(where_kvarray) Then" & vbCrLf
  324. out = out & " KVUnzip where_kvarray, where_keys, where_values" & vbCrLf
  325. out = out & " If Not IsEmpty(where_keys) Then" & vbCrLf
  326. out = out & " sql = sql & "" WHERE """ & vbCrLf
  327. out = out & " For i = 0 To UBound(where_keys)" & vbCrLf
  328. out = out & " If i > 0 Then sql = sql & "" AND """ & vbCrLf
  329. out = out & " sql = sql & "" "" & QI(where_keys(i)) & "" = ?""" & vbCrLf
  330. out = out & " Next" & vbCrLf
  331. out = out & " End If" & vbCrLf
  332. out = out & " End If" & vbCrLf
  333. out = out & " sql = sql & BuildOrderBy(order_string_or_array, """ & QPK & """)" & vbCrLf
  334. out = out & " Dim rs : Set rs = DAL.PagedQuery(sql, where_values, per_page, page_num)" & vbCrLf
  335. out = out & " If Not rs.EOF Then" & vbCrLf
  336. out = out & " rs.PageSize = per_page" & vbCrLf
  337. out = out & " rs.AbsolutePage = page_num" & vbCrLf
  338. out = out & " page_count = rs.PageCount" & vbCrLf
  339. out = out & " record_count = rs.RecordCount" & vbCrLf
  340. out = out & " End If" & vbCrLf
  341. out = out & " Set FindPaged = PagedList(rs, per_page)" & vbCrLf
  342. out = out & " Destroy rs" & vbCrLf
  343. out = out & " End Function" & vbCrLf & vbCrLf
  344. ' SearchTablePaged (OR col LIKE ?)
  345. out = out & " Public Function SearchTablePaged(columns_array, search_value, order_string_or_array, per_page, page_num, ByRef page_count, ByRef record_count)" & vbCrLf
  346. out = out & " Dim sql : sql = """ & selectBase & """" & vbCrLf
  347. out = out & " Dim i, params()" & vbCrLf
  348. out = out & " If IsArray(columns_array) And UBound(columns_array) >= 0 Then" & vbCrLf
  349. out = out & " sql = sql & "" WHERE """ & vbCrLf
  350. out = out & " ReDim params(UBound(columns_array))" & vbCrLf
  351. out = out & " For i = 0 To UBound(columns_array)" & vbCrLf
  352. out = out & " If i > 0 Then sql = sql & "" OR """ & vbCrLf
  353. out = out & " sql = sql & "" "" & QI(columns_array(i)) & "" LIKE ?""" & vbCrLf
  354. out = out & " params(i) = ""%"" & search_value & ""%""" & vbCrLf
  355. out = out & " Next" & vbCrLf
  356. out = out & " End If" & vbCrLf
  357. out = out & " sql = sql & BuildOrderBy(order_string_or_array, """ & QPK & """)" & vbCrLf
  358. out = out & " Dim rs : Set rs = DAL.PagedQuery(sql, params, per_page, page_num)" & vbCrLf
  359. out = out & " If Not rs.EOF Then" & vbCrLf
  360. out = out & " rs.PageSize = per_page" & vbCrLf
  361. out = out & " rs.AbsolutePage = page_num" & vbCrLf
  362. out = out & " page_count = rs.PageCount" & vbCrLf
  363. out = out & " record_count = rs.RecordCount" & vbCrLf
  364. out = out & " End If" & vbCrLf
  365. out = out & " Set SearchTablePaged = PagedList(rs, per_page)" & vbCrLf
  366. out = out & " Destroy rs" & vbCrLf
  367. out = out & " End Function" & vbCrLf & vbCrLf
  368. ' PagedList helper
  369. out = out & " Private Function PagedList(rs, per_page)" & vbCrLf
  370. out = out & " Dim list : Set list = new LinkedList_Class" & vbCrLf
  371. out = out & " Dim x : x = 0" & vbCrLf
  372. out = out & " Do While (per_page <= 0 Or x < per_page) And Not rs.EOF" & vbCrLf
  373. out = out & " list.Push Automapper.AutoMap(rs, ""POBO_" & tName & """)" & vbCrLf
  374. out = out & " x = x + 1" & vbCrLf
  375. out = out & " rs.MoveNext" & vbCrLf
  376. out = out & " Loop" & vbCrLf
  377. out = out & " Set PagedList = list" & vbCrLf
  378. out = out & " End Function" & vbCrLf & vbCrLf
  379. ' AddNew
  380. out = out & " Public Sub AddNew(ByRef model)" & vbCrLf
  381. out = out & " Dim sql : sql = ""INSERT INTO " & QTable & " (" & JoinQI(insertCols, ", ") & ") VALUES (" & Placeholders(UBound(insertCols)+1) & ")""" & vbCrLf
  382. out = out & " DAL.Execute sql, " & BuildModelParamsArray("model", insertCols) & vbCrLf
  383. out = out & " " & vbCrLf
  384. out = out & " ' Retrieve the newly inserted ID" & vbCrLf
  385. out = out & " On Error Resume Next" & vbCrLf
  386. out = out & " Dim rsId : Set rsId = DAL.Query(""SELECT @@IDENTITY AS NewID"", Empty)" & vbCrLf
  387. out = out & " If Err.Number <> 0 Then" & vbCrLf
  388. out = out & " ' Fallback for Access databases" & vbCrLf
  389. out = out & " Err.Clear" & vbCrLf
  390. out = out & " Set rsId = DAL.Query(""SELECT TOP 1 " & QPK & " FROM " & QTable & " ORDER BY " & QPK & " DESC"", Empty)" & vbCrLf
  391. out = out & " End If" & vbCrLf
  392. out = out & " On Error GoTo 0" & vbCrLf
  393. out = out & " " & vbCrLf
  394. out = out & " If Not rsId.EOF Then" & vbCrLf
  395. out = out & " If Not IsNull(rsId(0)) Then model." & idCol & " = rsId(0)" & vbCrLf
  396. out = out & " End If" & vbCrLf
  397. out = out & " Destroy rsId" & vbCrLf
  398. out = out & " End Sub" & vbCrLf & vbCrLf
  399. ' Update
  400. out = out & " Public Sub Update(model)" & vbCrLf
  401. out = out & " Dim sql : sql = ""UPDATE " & QTable & " SET " & JoinSetters(updateCols) & " WHERE " & QPK & " = ?""" & vbCrLf
  402. out = out & " DAL.Execute sql, " & BuildModelParamsArrayWithPK("model", updateCols, idCol) & vbCrLf
  403. out = out & " End Sub" & vbCrLf & vbCrLf
  404. ' Delete
  405. out = out & " Public Sub Delete(id)" & vbCrLf
  406. out = out & " Dim sql : sql = ""DELETE FROM " & QTable & " WHERE " & QPK & " = ?""" & vbCrLf
  407. out = out & " DAL.Execute sql, Array(id)" & vbCrLf
  408. out = out & " End Sub" & vbCrLf & vbCrLf
  409. ' Exceptions & helpers
  410. out = out & " Private Function RecordNotFoundException(ByVal field_name, ByVal field_val)" & vbCrLf
  411. out = out & " RecordNotFoundException = """ & tName & " record was not found with "" & field_name & "" = '"" & field_val & ""'.""" & vbCrLf
  412. out = out & " End Function" & vbCrLf & vbCrLf
  413. out = out & " Private Function QI(name)" & vbCrLf
  414. out = out & " QI = ""["" & Replace(CStr(name), ""]"", ""]]"") & ""]""" & vbCrLf
  415. out = out & " End Function" & vbCrLf & vbCrLf
  416. out = out & " Private Function BuildOrderBy(orderArg, defaultCol)" & vbCrLf
  417. out = out & " Dim s : s = """"" & vbCrLf
  418. out = out & " If IsEmpty(orderArg) Or IsNull(orderArg) Or orderArg = """" Then" & vbCrLf
  419. out = out & " s = "" ORDER BY "" & defaultCol & "" ASC""" & vbCrLf
  420. out = out & " ElseIf IsArray(orderArg) Then" & vbCrLf
  421. out = out & " Dim i : s = "" ORDER BY """ & vbCrLf
  422. out = out & " For i = 0 To UBound(orderArg)" & vbCrLf
  423. out = out & " If i > 0 Then s = s & "", """ & vbCrLf
  424. out = out & " s = s & QI(orderArg(i))" & vbCrLf
  425. out = out & " Next" & vbCrLf
  426. out = out & " Else" & vbCrLf
  427. out = out & " s = "" ORDER BY "" & QI(orderArg)" & vbCrLf
  428. out = out & " End If" & vbCrLf
  429. out = out & " BuildOrderBy = s" & vbCrLf
  430. out = out & " End Function" & vbCrLf
  431. out = out & "End Class" & vbCrLf & vbCrLf
  432. out = out & "Dim " & tName & "Repository__Singleton" & vbCrLf
  433. out = out & "Function " & tName & "Repository()" & vbCrLf
  434. out = out & " If IsEmpty(" & tName & "Repository__Singleton) Then" & vbCrLf
  435. out = out & " Set " & tName & "Repository__Singleton = new " & className & vbCrLf
  436. out = out & " End If" & vbCrLf
  437. out = out & " Set " & tName & "Repository = " & tName & "Repository__Singleton" & vbCrLf
  438. out = out & "End Function" & vbCrLf
  439. out = out & "%>" & vbCrLf
  440. BuildRepository = out
  441. End Function
  442. '==============================================================
  443. ' Helpers (generator side)
  444. '==============================================================
  445. Function GetAppSetting(key, configFilePath)
  446. Dim xml, nodes, node, j, localFso
  447. Set localFso = CreateObject("Scripting.FileSystemObject")
  448. Set xml = CreateObject("Microsoft.XMLDOM")
  449. If Not localFso.FileExists(configFilePath) Then
  450. GetAppSetting = "nothing" : Exit Function
  451. End If
  452. xml.Async = False
  453. xml.Load(configFilePath)
  454. If xml.ParseError.ErrorCode <> 0 Then
  455. GetAppSetting = "nothing" : Exit Function
  456. End If
  457. Set nodes = xml.selectNodes("//appSettings/add")
  458. For j = 0 To nodes.Length - 1
  459. Set node = nodes.Item(j)
  460. If node.getAttribute("key") = key Then
  461. GetAppSetting = node.getAttribute("value")
  462. Exit Function
  463. End If
  464. Next
  465. GetAppSetting = "nothing"
  466. End Function
  467. Function Nz(val, defaultVal)
  468. If IsNull(val) Or IsEmpty(val) Then
  469. Nz = defaultVal
  470. Else
  471. Nz = val
  472. End If
  473. End Function
  474. Sub ArraySortByParallel(keys, arrs)
  475. Dim iLocal, jLocal, kLocal, tmpKey, tmp
  476. For iLocal = 0 To UBound(keys) - 1
  477. For jLocal = iLocal + 1 To UBound(keys)
  478. If keys(jLocal) < keys(iLocal) Then
  479. tmpKey = keys(iLocal) : keys(iLocal) = keys(jLocal) : keys(jLocal) = tmpKey
  480. For kLocal = 0 To UBound(arrs)
  481. tmp = arrs(kLocal)(iLocal)
  482. arrs(kLocal)(iLocal) = arrs(kLocal)(jLocal)
  483. arrs(kLocal)(jLocal) = tmp
  484. Next
  485. End If
  486. Next
  487. Next
  488. End Sub
  489. Function InArrayInsensitive(a, val)
  490. Dim z
  491. InArrayInsensitive = False
  492. For z = 0 To UBound(a)
  493. If StrEqualCI(a(z), val) Then InArrayInsensitive = True : Exit Function
  494. Next
  495. End Function
  496. Function StrEqualCI(a, b)
  497. StrEqualCI = (LCase(CStr(a)) = LCase(CStr(b)))
  498. End Function
  499. Function QI(name)
  500. QI = "[" & Replace(CStr(name), "]", "]]") & "]"
  501. End Function
  502. Function JoinQI(a, sep)
  503. Dim j, s : s = ""
  504. For j = 0 To UBound(a)
  505. If j > 0 Then s = s & sep
  506. s = s & QI(a(j))
  507. Next
  508. JoinQI = s
  509. End Function
  510. Function Placeholders(n)
  511. Dim j, s : s = ""
  512. For j = 1 To n
  513. If j > 1 Then s = s & ", "
  514. s = s & "?"
  515. Next
  516. Placeholders = s
  517. End Function
  518. Function JoinSetters(a)
  519. Dim j, s : s = ""
  520. For j = 0 To UBound(a)
  521. If j > 0 Then s = s & ", "
  522. s = s & QI(a(j)) & " = ?"
  523. Next
  524. JoinSetters = s
  525. End Function
  526. Function BuildModelParamsArray(modelName, a)
  527. Dim j, s : s = "Array("
  528. For j = 0 To UBound(a)
  529. If j > 0 Then s = s & ", "
  530. s = s & modelName & "." & a(j)
  531. Next
  532. s = s & ")"
  533. BuildModelParamsArray = s
  534. End Function
  535. Function BuildModelParamsArrayWithPK(modelName, a, pk)
  536. Dim j, s : s = "Array("
  537. For j = 0 To UBound(a)
  538. If j > 0 Then s = s & ", "
  539. s = s & modelName & "." & a(j)
  540. Next
  541. s = s & ", " & modelName & "." & pk & ")"
  542. BuildModelParamsArrayWithPK = s
  543. End Function
  544. ' Validate identifier (table name, column name, etc.)
  545. Function IsValidIdentifier(name)
  546. If IsEmpty(name) Or Len(name) = 0 Then
  547. IsValidIdentifier = False
  548. Exit Function
  549. End If
  550. Dim i, ch
  551. For i = 1 To Len(name)
  552. ch = Mid(name, i, 1)
  553. ' Allow a-z, A-Z, 0-9, and underscore only
  554. If Not ((ch >= "a" And ch <= "z") Or _
  555. (ch >= "A" And ch <= "Z") Or _
  556. (ch >= "0" And ch <= "9") Or _
  557. ch = "_") Then
  558. IsValidIdentifier = False
  559. Exit Function
  560. End If
  561. Next
  562. IsValidIdentifier = True
  563. End Function

Powered by TurnKey Linux.