浏览代码

'init'

master
Daniel Covington 1 个月前
当前提交
264231aad1
共有 39 个文件被更改,包括 7080 次插入0 次删除
  1. +78
    -0
      README.md
  2. +37
    -0
      app/controllers/ErrorController.asp
  3. +42
    -0
      app/controllers/HomeController.asp
  4. +2
    -0
      app/controllers/autoload_controllers.asp
  5. +55
    -0
      app/views/Error/NotFound.asp
  6. +85
    -0
      app/views/Home/index.asp
  7. +8
    -0
      app/views/shared/footer.asp
  8. +85
    -0
      app/views/shared/header.asp
  9. +21
    -0
      core/autoload_core.asp
  10. +536
    -0
      core/helpers.asp
  11. +159
    -0
      core/lib.Automapper.asp
  12. +155
    -0
      core/lib.CDOEmail.asp
  13. +914
    -0
      core/lib.Collections.asp
  14. +110
    -0
      core/lib.ControllerRegistry.asp
  15. +29
    -0
      core/lib.DAL.asp
  16. +113
    -0
      core/lib.Data.asp
  17. +202
    -0
      core/lib.Enumerable.asp
  18. +178
    -0
      core/lib.ErrorHandler.asp
  19. +151
    -0
      core/lib.Flash.asp
  20. +79
    -0
      core/lib.FormCache.asp
  21. +77
    -0
      core/lib.HTML.Security.asp
  22. +282
    -0
      core/lib.HTML.asp
  23. +439
    -0
      core/lib.Migrations.asp
  24. +262
    -0
      core/lib.Routes.asp
  25. +73
    -0
      core/lib.Strings.asp
  26. +405
    -0
      core/lib.Upload.asp
  27. +250
    -0
      core/lib.Validations.asp
  28. +45
    -0
      core/lib.crypto.helper.asp
  29. +115
    -0
      core/lib.helpers.asp
  30. +284
    -0
      core/lib.json.asp
  31. +166
    -0
      core/mvc.asp
  32. +147
    -0
      core/router.wsc
  33. 二进制
      db/webdata.accdb
  34. +13
    -0
      public/Default.asp
  35. +70
    -0
      public/web.config
  36. +637
    -0
      scripts/GenerateRepo.vbs
  37. 二进制
      scripts/generateController.vbs
  38. +162
    -0
      scripts/generateMigration.vbs
  39. +614
    -0
      scripts/runMigrations.vbs

+ 78
- 0
README.md 查看文件

@@ -0,0 +1,78 @@
# RouteKit Classic ASP - MVC Starter

A clean starting point for building Classic ASP applications with the RouteKit MVC framework.

## Quick Setup

1. Copy this folder to your IIS server
2. Point your IIS site root to the `public/` folder
3. Update `public/web.config`:
- Set `ConnectionString` to your database path
- Set `ErrorLogPath` if you want file logging
4. Ensure the IIS URL Rewrite module is installed
5. Browse to `http://localhost/` — you should see the welcome page

## Project Structure

```
MVC-Starter/
public/ # IIS ROOT - point your IIS site here
Default.asp # Front controller (entry point)
web.config # IIS config, routes, connection strings
core/ # Framework core (do not modify)
autoload_core.asp # Loads all core libraries
router.wsc # Route matching engine
mvc.asp # MVC dispatcher
lib.*.asp # Core libraries
app/
controllers/ # Your controllers go here
views/ # Your views go here
shared/ # Shared layout (header, footer)
models/ # POBOs go here
repositories/ # Repository classes go here
db/
migrations/ # Database migrations
webdata.accdb # Access database
scripts/ # Code generators
generateController.vbs
generateMigration.vbs
GenerateRepo.vbs
runMigrations.vbs
```

## Adding a New Feature

### 1. Generate a migration
```bash
cscript //nologo scripts\generateMigration.vbs create_my_table
```

### 2. Generate POBO and Repository
```bash
cscript //nologo scripts\GenerateRepo.vbs /table:my_table /pk:id
```
Move generated files to `app/models/` and `app/repositories/`.

### 3. Generate a controller
```bash
cscript //nologo scripts\generateController.vbs MyController "Index;Show(id);Create;Store"
```
Move generated file to `app/controllers/`.

### 4. Wire it up
- Register in `core/lib.ControllerRegistry.asp`
- Include in `app/controllers/autoload_controllers.asp`
- Add routes in `public/Default.asp`
- Create views in `app/views/MyController/`

## Included Controllers

- **HomeController** - Welcome page at `/`
- **ErrorController** - 404 handler at `/404`

## Requirements

- Windows Server with IIS
- Classic ASP enabled
- IIS URL Rewrite module
- Microsoft Access Database Engine (for .accdb support)

+ 37
- 0
app/controllers/ErrorController.asp 查看文件

@@ -0,0 +1,37 @@
<%
Class ErrorController_Class
Private m_useLayout
Private Sub Class_Initialize()
m_useLayout = True
End Sub

Public Property Get useLayout
useLayout = m_useLayout
End Property

Public Property Let useLayout(v)
m_useLayout = v
End Property
Public Sub Index()
Response.Write "Index called"
End Sub

Public Sub NotFound()
Response.Status = "404 Not Found"
%>
<!--#include file="../Views/Error/NotFound.asp" -->
<%
End Sub

End Class

Dim ErrorController_Class__Singleton
Function ErrorController()
If IsEmpty(ErrorController_Class__Singleton) Then
Set ErrorController_Class__Singleton = New ErrorController_Class
End If
Set ErrorController = ErrorController_Class__Singleton
End Function
%>

+ 42
- 0
app/controllers/HomeController.asp 查看文件

@@ -0,0 +1,42 @@
<%
Class HomeController_Class
Private m_useLayout
Private m_title

Private Sub Class_Initialize()
m_useLayout = True
m_title = "Home"
End Sub

Public Property Get useLayout
useLayout = m_useLayout
End Property

Public Property Let useLayout(v)
m_useLayout = v
End Property

Public Property Get Title
Title = m_title
End Property

Public Property Let Title(v)
m_title = v
End Property

Public Sub index()
%>
<!--#include file="../views/Home/index.asp" -->
<%
End Sub

End Class

Dim HomeController_Class__Singleton
Function HomeController()
If IsEmpty(HomeController_Class__Singleton) Then
Set HomeController_Class__Singleton = New HomeController_Class
End If
Set HomeController = HomeController_Class__Singleton
End Function
%>

+ 2
- 0
app/controllers/autoload_controllers.asp 查看文件

@@ -0,0 +1,2 @@
<!--#include file="HomeController.asp" -->
<!--#include file="ErrorController.asp" -->

+ 55
- 0
app/views/Error/NotFound.asp 查看文件

@@ -0,0 +1,55 @@
<div class="main-content">
<div class="d-flex align-items-center justify-content-center min-vh-100 bg-light">
<div class="card shadow-sm border-0 text-center p-4 p-md-5 error-card">
<div class="mb-3">
<i class="bi bi-exclamation-triangle-fill display-3 text-warning"></i>
</div>
<h1 class="h3 mb-3">404 - Page Not Found</h1>
<p class="text-muted mb-3">
The page you’re looking for could not be found. It may have been moved, deleted,
or the address might be incorrect.
</p>
<%
Dim redirectSeconds : redirectSeconds = GetAppSetting("Error404RedirectSeconds")
If redirectSeconds = "nothing" Or Not IsNumeric(redirectSeconds) Then redirectSeconds = 5
%>
<p class="text-muted mb-3">
You'll be redirected to the homepage in
<span id="countdown"><%= redirectSeconds %></span> seconds.
</p>
<a href="/" class="btn btn-primary mt-2">
Go to Homepage Now
</a>
</div>
</div>
</div>

<style>
.error-card {
max-width: 540px;
border-radius: 1rem;
}

.error-card .bi {
line-height: 1;
}
</style>

<script>
(function () {
let seconds = <%= redirectSeconds %>;
const countdown = document.getElementById('countdown');

const timer = setInterval(function () {
seconds--;
if (countdown) {
countdown.textContent = seconds;
}

if (seconds <= 0) {
clearInterval(timer);
window.location.href = '/';
}
}, 1000);
})();
</script>

+ 85
- 0
app/views/Home/index.asp 查看文件

@@ -0,0 +1,85 @@


<div class="row mb-4">
<div class="col-lg-8">
<div class="card shadow-sm mb-3">
<div class="card-body">
<h1 class="h3 mb-3">Welcome to RouteKit Classic ASP</h1>
<p class="text-muted">
Your lightweight, opinionated MVC-style framework for Classic ASP.
</p>
<p>
This <code>Home.Index</code> view is using the shared
<code>Header.asp</code> and <code>Footer.asp</code> layout files.
</p>
<p class="mb-0">
Start by wiring up your controllers, repositories, and views — this page is just a
friendly placeholder so you know everything is hooked up correctly.
</p>
</div>
</div>
</div>

<div class="col-lg-4">
<div class="card border-0 bg-light mb-3">
<div class="card-body">
<h2 class="h5 mb-3">Quick info</h2>
<ul class="list-unstyled mb-0 small">
<li class="mb-1">
<strong>View:</strong>
<code>app/Views/Home.Index.asp</code>
</li>
<li class="mb-1">
<strong>Layout:</strong>
<code>Shared/Header.asp</code> &amp; <code>Shared/Footer.asp</code>
</li>
<li class="mb-1">
<strong>Default route:</strong>
typically <code>/Home/Index</code> or <code>/</code> via the dispatcher.
</li>
</ul>
</div>
</div>
</div>
</div>

<div class="row gy-3">
<div class="col-md-4">
<div class="card h-100 shadow-sm">
<div class="card-body">
<h2 class="h5">Next step: Controllers</h2>
<p class="small text-muted">
Use your <code>generateController.vbs</code> script to scaffold new controllers.
</p>
<pre class="small mb-0"><code>cscript //nologo Scripts\generateController.vbs ^
Home "Index"</code></pre>
</div>
</div>
</div>

<div class="col-md-4">
<div class="card h-100 shadow-sm">
<div class="card-body">
<h2 class="h5">POBO &amp; Repository</h2>
<p class="small text-muted">
Generate strongly-typed POBOs and repositories from your Access/SQL schema.
</p>
<pre class="small mb-0"><code>cscript //nologo Scripts\GenerateRepo.vbs ^
/table:Users /pk:UserId</code></pre>
</div>
</div>
</div>

<div class="col-md-4">
<div class="card h-100 shadow-sm">
<div class="card-body">
<h2 class="h5">Where to put stuff</h2>
<ul class="small mb-0">
<li><code>/core/</code> – framework libs (DAL, routing, helpers)</li>
<li><code>/app/Views/</code> – pages like this one</li>
<li><code>/public/</code> – IIS root (Default.asp, web.config)</li>
</ul>
</div>
</div>
</div>
</div>

+ 8
- 0
app/views/shared/footer.asp 查看文件

@@ -0,0 +1,8 @@
</div>
</main>

<!-- Bootstrap bundle (with Popper) -->
<script src="https://cdn.jsdelivr.net/npm/bootstrap@5.3.3/dist/js/bootstrap.bundle.min.js"></script>

</body>
</html>

+ 85
- 0
app/views/shared/header.asp 查看文件

@@ -0,0 +1,85 @@
<!doctype html>
<%
Response.Charset = "utf-8"
Response.CodePage = 65001

' Safe title resolution
Dim pageTitle
If IsObject(CurrentController) Then
On Error Resume Next
pageTitle = CurrentController.Title
If Err.Number <> 0 Then
pageTitle = "RouteKit Classic ASP"
Err.Clear
End If
On Error GoTo 0
End If

If Len(pageTitle) = 0 Then pageTitle = "RouteKit Classic ASP"
%>
<html lang="en">
<head>
<meta charset="utf-8" />
<title><%= pageTitle %></title>
<meta name="viewport" content="width=device-width, initial-scale=1" />

<!-- Bootstrap CSS -->
<link href="https://cdn.jsdelivr.net/npm/bootstrap@5.3.3/dist/css/bootstrap.min.css" rel="stylesheet" />
<!-- Bootstrap Icons (optional) -->
<link href="https://cdn.jsdelivr.net/npm/bootstrap-icons@1.11.3/font/bootstrap-icons.css" rel="stylesheet" />

<!-- App CSS -->
<link href="/css/site.css" rel="stylesheet" />

<style>
body {
background-color: #f5f5f5;
}
.rk-navbar-brand {
font-weight: 600;
letter-spacing: 0.03em;
}
main.routekit-main {
padding-top: 1.5rem;
padding-bottom: 2rem;
}
</style>
</head>
<body>
<!-- Top navbar -->
<nav class="navbar navbar-expand-lg navbar-dark bg-dark">
<div class="container-fluid">
<a class="navbar-brand rk-navbar-brand" href="/">
RouteKit
<span class="text-secondary small">Classic ASP</span>
</a>

<button class="navbar-toggler" type="button" data-bs-toggle="collapse" data-bs-target="#rkMainNav" aria-controls="rkMainNav" aria-expanded="false" aria-label="Toggle navigation">
<span class="navbar-toggler-icon"></span>
</button>

<div class="collapse navbar-collapse" id="rkMainNav">
<ul class="navbar-nav me-auto mb-2 mb-lg-0">
<li class="nav-item">
<a class="nav-link" href="/">Home</a>
</li>
<!-- Add more shared nav items here -->
' <li class="nav-item"><a class="nav-link" href="/docs">Docs</a></li>
</ul>

' Right-side area (e.g., user info / login)
' You can wire this up to your auth later.
<ul class="navbar-nav mb-2 mb-lg-0">
' <li class="nav-item">
' <a class="nav-link" href="/login">Login</a>
' </li>
</ul>
</div>
</div>
</nav>

<!-- Main container for views -->
<main class="routekit-main">
<div class="container">

<% Flash().ShowErrorsIfPresent : Flash().ShowSuccessIfPresent %>

+ 21
- 0
core/autoload_core.asp 查看文件

@@ -0,0 +1,21 @@
<!--#include file="../Core/helpers.asp"-->
<!--#include file="../Core/lib.ErrorHandler.asp"-->
<!--#include file="../Core/lib.ControllerRegistry.asp"-->
<!--#include file="../Core/mvc.asp"-->
<!--#include file="../Core/lib.DAL.asp"-->
<!--#include file="../Core/lib.Data.asp"-->
<!--#include file="../Core/lib.Migrations.asp"-->
<% Dim router : Set router = GetObject("script:"& Server.MapPath("../Core/router.wsc") & "") %>
<!--#include file="../Core/lib.collections.asp"-->
<!--#include file="../Core/lib.HTML.asp"-->
<!--#include file="../Core/lib.Routes.asp"-->
<!--#include file="../Core/lib.Flash.asp"-->
<!--#include file="../Core/lib.FormCache.asp"-->
<!--#include file="../Core/lib.HTML.Security.asp"-->
<!--#include file="../Core/lib.AutoMapper.asp"-->
<!--#include file="../Core/lib.CDOEmail.asp"-->
<!--#include file="../Core/lib.Upload.asp"-->
<!--#include file="../Core/lib.json.asp"-->
<!--#include file="../Core/lib.helpers.asp"-->
<!--#include file="../Core/lib.crypto.helper.asp"-->
<!--#include file="../Core/lib.Enumerable.asp"-->

+ 536
- 0
core/helpers.asp 查看文件

@@ -0,0 +1,536 @@
<%
Function QuoteValue(val)
if IsWrappedInSingleQuotes(val) then
QuoteValue = val
Exit Function
end if
Select Case VarType(val)
Case vbString
QuoteValue = "'" & Replace(val, "'", "''") & "'"
Case vbDate
if conn.Provider = "Microsoft.Jet.OLEDB.4.0" or conn.Provider = "Microsoft.ACE.OLEDB.12.0" then
QuoteValue = "#" & FormatDateTime(val, 0) & "#"
else
' SQL Server
QuoteValue = "'" & FormatDateTime(val, 0) & "'"
end if
Case vbNull, vbEmpty
QuoteValue = "Null"
Case vbBoolean
' Return boolean values without quotes
QuoteValue = "'" & CStr(val) & "'"
Case Else
If IsNumeric(val) Then
QuoteValue = CLng(val)
Else
QuoteValue = CStr(val)
End If
End Select
End Function

Public Function GetAppSetting(key)
Dim cacheKey, xml, nodes, node, i
cacheKey = "AppSetting_" & key

' Check Application cache first for performance
If Not IsEmpty(Application(cacheKey)) Then
GetAppSetting = Application(cacheKey)
Exit Function
End If

' Load from web.config only if not cached
Set xml = Server.CreateObject("Microsoft.XMLDOM")
xml.Load(Server.MapPath("web.config"))
Set nodes = xml.selectNodes("//appSettings/add")
For i = 0 To nodes.Length - 1
Set node = nodes.Item(i)
If node.getAttribute("key") = key Then
GetAppSetting = node.getAttribute("value")
' Cache the value for subsequent requests
Application.Lock
Application(cacheKey) = GetAppSetting
Application.Unlock
Exit Function
End If
Next
GetAppSetting = "nothing"
End Function

Public Sub ShowServerVariables
Dim varName, htmlTable
htmlTable = "<table border='1' cellspacing='0' cellpadding='5'>"
htmlTable = htmlTable & "<thead><tr><th>Variable Name</th><th>Value</th></tr></thead><tbody>"

' Loop through all server variables
For Each varName In Request.ServerVariables
htmlTable = htmlTable & "<tr>"
htmlTable = htmlTable & "<td>" & Server.HTMLEncode(varName) & "</td>"
htmlTable = htmlTable & "<td>" & Server.HTMLEncode(Request.ServerVariables(varName)) & "</td>"
htmlTable = htmlTable & "</tr>"
Next

htmlTable = htmlTable & "</tbody></table>"

' Output the HTML table
Response.Write(htmlTable)
End Sub
'------------------------------------------------------------------------------
' Utility: IIf Function for VBScript
' Usage: result = IIf(condition, trueValue, falseValue)
'------------------------------------------------------------------------------
Function IIf(condition, trueValue, falseValue)
On Error Resume Next
If CBool(condition) Then
IIf = trueValue
Else
IIf = falseValue
End If
If Err.Number <> 0 Then
' Optional: handle or log error in conversion/evaluation
Err.Clear
End If
On Error GoTo 0
End Function

'-----------------------------
' Utility: Generic Error Reporter
'-----------------------------
Public Sub ErrorCheck(context)
If Err.Number <> 0 Then
Dim errHtml
errHtml = "<div style='padding:10px; border:2px solid red; background:#fdd; font-family:Verdana; font-size:12px;'>"
errHtml = errHtml & "<strong>Error occurred" & IIf(Not IsEmpty(context) And context <> "", ": " & context, "") & "</strong><br />"
errHtml = errHtml & "<em>Time:</em> " & Now() & "<br />"
errHtml = errHtml & "<em>Number:</em> " & Err.Number & "<br />"
errHtml = errHtml & "<em>Description:</em> " & Server.HTMLEncode(Err.Description) & "<br />"
If Len(Err.Source) > 0 Then
errHtml = errHtml & "<em>Source:</em> " & Server.HTMLEncode(Err.Source) & "<br />"
End If
errHtml = errHtml & "</div>"
Response.Write errHtml
Err.Clear
End If
End Sub

'------------------------------------------------------------------------------
' Utility: TrimQueryParams
' Removes everything from the first "?" or "&" onward.
' Usage:
' CleanPath = TrimQueryParams(rawPath)
'------------------------------------------------------------------------------
Function TrimQueryParams(rawPath)
Dim posQ, posA, cutPos

' find the first occurrences of "?" and "&"
posQ = InStr(rawPath, "?")
posA = InStr(rawPath, "&")

' determine the earliest cut position (>0)
If posQ > 0 And posA > 0 Then
cutPos = IIf(posQ < posA, posQ, posA)
ElseIf posQ > 0 Then
cutPos = posQ
ElseIf posA > 0 Then
cutPos = posA
Else
cutPos = 0
End If

' if found, return up to just before that char
If cutPos > 0 Then
TrimQueryParams = Left(rawPath, cutPos - 1)
Else
TrimQueryParams = rawPath
End If
End Function

Sub Destroy(o)
if isobject(o) then
if not o is nothing then
on error resume next
o.close
on error goto 0
set o = nothing
end if
end if
End Sub

'prepends indents
Private Sub puti(v)
put Spaces(m_indent) & v
End Sub

Sub put(v)
Select Case typename(v)
Case "LinkedList_Class" : response.write join(v.TO_Array, ", ")
Case "DynamicArray_Class" : response.write JoinList(v)
Case "Variant()" : response.write join(v, ", ")
Case else : response.write v
End Select
End Sub

Sub put_
put "<br>"
End Sub

Sub putl(v)
put v
put_
End Sub
'---------------------------------------------------------------------------------------------------------------------
'Wrapper for Server.HTMLEncode() -- makes it easier on the eyes when reading the HTML code
Function H(s)
If Not IsEmpty(s) and Not IsNull(s) then
H = Server.HTMLEncode(s)
Else
H = ""
End If
End Function


'=======================================================================================================================
' Adapted from Tolerable library
'=======================================================================================================================
' This subroutine allows us to ignore the difference
' between object and primitive assignments. This is
' essential for many parts of the engine.
Public Sub Assign(ByRef var, ByVal val)
If IsObject(val) Then
Set var = val
Else
var = val
End If
End Sub

' This is similar to the ? : operator of other languages.
' Unfortunately, both the if_true and if_false "branches"
' will be evalauted before the condition is even checked. So,
' you'll only want to use this for simple expressions.
Public Function Choice(ByVal cond, ByVal if_true, ByVal if_false)
If cond Then
Assign Choice, if_true
Else
Assign Choice, if_false
End If
End Function

' Allows single-quotes to be used in place of double-quotes.
' Basically, this is a cheap trick that can make it easier
' to specify Lambdas.
Public Function Q(ByVal input)
Q = Replace(input, "'", """")
End Function

Function SurroundString(inputVar)
If VarType(inputVar) = vbString Then
SurroundString = """" & inputVar & """"
Else
SurroundString = inputVar
End If
End Function

Function SurroundStringInArray(arr)
Dim i
For i = LBound(arr) To UBound(arr)
If IsString(arr(i)) Then
arr(i) = """" & arr(i) & """"
End If
Next
SurroundStringInArray = arr
End Function
'-----------------------------------------------------------------------------------------------------------------------
'Boolean type checkers
'Don't forget IsArray is built-in!
Function IsString(value)
IsString = Choice(typename(value) = "String", true, false)
End Function

Function IsDict(value)
IsDict = Choice(typename(value) = "Dictionary", true, false)
End Function

Function IsRecordset(value)
IsRecordset = Choice(typename(value) = "Recordset", true, false)
End Function

Function IsLinkedList(value)
IsLinkedList = Choice(typename(value) = "LinkedList_Class", true, false)
End Function

Function IsArray(value)
IsArray = Choice(typename(value) = "Variant()", true, false)
End Function

'--------------------------------------------------------------------
' Returns True when the named key is present in Session.Contents
' • Handles scalars (String, Integer, etc.), objects, Empty, and Null
'--------------------------------------------------------------------
Function SessionHasKey(keyName)
'Loop over the existing keys—Session.Contents is like a dictionary
Dim k
For Each k In Session.Contents
If StrComp(k, keyName, vbTextCompare) = 0 Then
SessionHasKey = True
Exit Function
End If
Next
SessionHasKey = False 'not found
End Function

Function RenderObjectsAsTable(arr,boolUseTabulator)
Dim html, propNames, i, j, obj, val, pkName, isPk

If IsEmpty(arr) Or Not IsArray(arr) Then
RenderObjectsAsTable = "<!-- no data -->"
Exit Function
End If

Set obj = arr(0)
On Error Resume Next
propNames = obj.Properties
pkName = obj.PrimaryKey
On Error GoTo 0

If IsEmpty(propNames) Or Len(pkName) = 0 Then
RenderObjectsAsTable = "<!-- missing properties or primary key -->"
Exit Function
End If

html = "<div class='table-wrapper'>" & vbCrLf
html = html & "<table class='pobo-table' id='pobo-table'>" & vbCrLf
html = html & " <thead><tr>" & vbCrLf
For i = 0 To UBound(propNames)
html = html & " <th>" & Server.HTMLEncode(propNames(i)) & "</th>" & vbCrLf
Next
html = html & " </tr></thead>" & vbCrLf
html = html & " <tbody>" & vbCrLf

For j = 0 To UBound(arr)
Set obj = arr(j)
html = html & " <tr>" & vbCrLf
For i = 0 To UBound(propNames)
val = GetDynamicProperty(obj, propNames(i))
isPk = (StrComp(propNames(i), pkName, vbTextCompare) = 0)

If IsNull(val) Or IsEmpty(val) Then
val = "&nbsp;"
ElseIf IsDate(val) Then
val = FormatDateTime(val, vbShortDate)
ElseIf VarType(val) = vbBoolean Then
val = IIf(val, "True", "False")
Else
val = CStr(val)
Dim maxLen : maxLen = CInt(GetAppSetting("TableCellMaxLength"))
If maxLen <= 0 Then maxLen = 90
If Len(val) > maxLen Then
val = Left(val, maxLen - 3) & "..."
End If
val = Server.HTMLEncode(val)
End If

If isPk and boolUseTabulator = False Then
val = "<a href=""" & obj.Tablename & "/edit/" & GetDynamicProperty(obj, pkName) & """ class=""table-link"">" & val & "</a>"
End If

html = html & " <td>" & val & "</td>" & vbCrLf
Next
html = html & " </tr>" & vbCrLf
Next

html = html & " </tbody>" & vbCrLf & "</table>" & vbCrLf & "</div>"
RenderObjectsAsTable = html
End Function

Function RenderFormFromObject(obj)
Dim html, propNames, i, name, val, inputType
Dim pkName, tableName, checkedAttr

On Error Resume Next
propNames = obj.Properties
pkName = obj.PrimaryKey
tableName = obj.TableName
On Error GoTo 0

If IsEmpty(propNames) Or Len(pkName) = 0 Then
RenderFormFromObject = "<!-- Invalid object -->"
Exit Function
End If

html = "<form method='post' action='/" & tableName & "/save' class='article-content'>" & vbCrLf

For i = 0 To UBound(propNames)
name = propNames(i)
val = GetDynamicProperty(obj, name)

' Handle nulls
If IsNull(val) Then val = ""

' Primary key → hidden input
If StrComp(name, pkName, vbTextCompare) = 0 Then
html = html & " <input type='hidden' name='" & name & "' value='" & Server.HTMLEncode(val) & "' />" & vbCrLf
'Continue For
End If

html = html & " <div class='form-group'>" & vbCrLf
html = html & " <label for='" & name & "'>" & name & "</label>" & vbCrLf

Select Case True
Case VarType(val) = vbBoolean
checkedAttr = ""
If val = True Then checkedAttr = " checked"
html = html & " <input type='checkbox' class='form-check-input' name='" & name & "' id='" & name & "' value='true'" & checkedAttr & " />" & vbCrLf

Case IsDate(val)
html = html & " <input type='date' class='form-control' name='" & name & "' id='" & name & "' value='" & FormatDateForInput(val) & "' />" & vbCrLf

Case IsNumeric(val)
html = html & " <input type='number' class='form-control' name='" & name & "' id='" & name & "' value='" & val & "' />" & vbCrLf

Case Len(val) > CInt(GetAppSetting("FormTextareaThreshold"))
html = html & " <textarea class='form-control' name='" & name & "' id='" & name & "' rows='6'>" & Server.HTMLEncode(val) & "</textarea>" & vbCrLf

Case Else
html = html & " <input type='text' class='form-control' name='" & name & "' id='" & name & "' value='" & Server.HTMLEncode(val) & "' />" & vbCrLf
End Select

html = html & " </div>" & vbCrLf
Next

html = html & " <button type='submit' class='btn btn-primary btn-lg'>Save</button>" & vbCrLf
html = html & "</form>" & vbCrLf

RenderFormFromObject = html
End Function


Function GetDynamicProperty(obj, propName)
On Error Resume Next
Dim result
Execute "result = obj." & propName
If Err.Number <> 0 Then
result = ""
Err.Clear
End If
GetDynamicProperty = result
On Error GoTo 0
End Function

Function FormatDateForInput(val)
If IsDate(val) Then
Dim yyyy, mm, dd
yyyy = Year(val)
mm = Right("0" & Month(val), 2)
dd = Right("0" & Day(val), 2)
FormatDateForInput = yyyy & "-" & mm & "-" & dd
Else
FormatDateForInput = ""
End If
End Function


'-------------------------------------------------------------
' Returns obj.<propName> for any public VBScript class property
'-------------------------------------------------------------
Function GetObjProp(o, pName)
Dim tmp
' Build a tiny statement like: tmp = o.UserID
Execute "tmp = o." & pName
GetObjProp = tmp
End Function

Function GenerateSlug(title)
Dim slug
slug = LCase(title) ' Convert to lowercase
slug = Replace(slug, "&", "and") ' Replace ampersands
slug = Replace(slug, "'", "") ' Remove apostrophes
slug = Replace(slug, """", "") ' Remove quotes
slug = Replace(slug, "–", "-") ' Replace en dash
slug = Replace(slug, "—", "-") ' Replace em dash
slug = Replace(slug, "/", "-") ' Replace slashes
slug = Replace(slug, "\", "-") ' Replace backslashes

' Remove all non-alphanumeric and non-hyphen/space characters
Dim i, ch, clean
clean = ""
For i = 1 To Len(slug)
ch = Mid(slug, i, 1)
If (ch >= "a" And ch <= "z") Or (ch >= "0" And ch <= "9") Or ch = " " Or ch = "-" Then
clean = clean & ch
End If
Next

' Replace multiple spaces or hyphens with single hyphen
Do While InStr(clean, " ") > 0
clean = Replace(clean, " ", " ")
Loop
clean = Replace(clean, " ", "-")
Do While InStr(clean, "--") > 0
clean = Replace(clean, "--", "-")
Loop

' Trim leading/trailing hyphens
Do While Left(clean, 1) = "-"
clean = Mid(clean, 2)
Loop
Do While Right(clean, 1) = "-"
clean = Left(clean, Len(clean) - 1)
Loop

GenerateSlug = clean
End Function

Function GetRawJsonFromRequest()
Dim stream, rawJson
Set stream = Server.CreateObject("ADODB.Stream")
stream.Type = 1 ' adTypeBinary
stream.Open
stream.Write Request.BinaryRead(Request.TotalBytes)
stream.Position = 0
stream.Type = 2 ' adTypeText
stream.Charset = "utf-8"
rawJson = stream.ReadText
stream.Close
Set stream = Nothing

GetRawJsonFromRequest = rawJson
End Function

Function Active(controllerName)
On Error Resume Next
If Replace(Lcase(router.Resolve(Request.ServerVariables("REQUEST_METHOD"), TrimQueryParams(Request.ServerVariables("HTTP_X_ORIGINAL_URL")))(0)),"controller","") = LCase(controllerName) Then
Active = "active"
Else
Active = ""
End If
On Error GoTo 0
End Function

'====================================================================
' FormatDateForSql
' Converts a VBScript Date to a SQL Server-compatible string
' Output: 'YYYY-MM-DD HH:MM:SS'
'====================================================================
Function FormatDateForSql(vbDate)
If IsNull(vbDate) Or vbDate = "" Then
FormatDateForSql = "NULL"
Exit Function
End If
' Ensure vbDate is a valid date
If Not IsDate(vbDate) Then
Err.Raise vbObjectError + 1000, "FormatDateForSql", "Invalid date: " & vbDate
End If
Dim yyyy, mm, dd, hh, nn, ss
yyyy = Year(vbDate)
mm = Right("0" & Month(vbDate), 2)
dd = Right("0" & Day(vbDate), 2)
hh = Right("0" & Hour(vbDate), 2)
nn = Right("0" & Minute(vbDate), 2)
ss = Right("0" & Second(vbDate), 2)

' Construct SQL Server datetime literal
FormatDateForSql = "'" & yyyy & "-" & mm & "-" & dd & " " & hh & ":" & nn & ":" & ss & "'"
End Function

%>

+ 159
- 0
core/lib.Automapper.asp 查看文件

@@ -0,0 +1,159 @@
<%
'=======================================================================================================================
' AUTOMAPPER CLASS
'=======================================================================================================================

'Side Effects: Since src and target are passed ByRef to reduce unnecessary copying, if src is a recordset then the
' current record pointer is modified using src.MoveFirst and src.MoveNext. The end result is the current
' record pointer ends the operation at src.EOF.

Class Automapper_Class
Private m_src
Private m_target
Private m_statements
Private m_statements_count
Private Property Get Src : set Src = m_src : End Property
Private Property Get Target : set Target = m_target : End Property
Private Sub Class_Initialize
m_statements_count = -1
ReDim m_statements(-1)
End Sub
Private Sub ResetState
m_statements_count = -1
ReDim m_statements(-1)
Set m_src = Nothing
Set m_target = Nothing
End Sub

'Maps all rs or object fields to corresponding fields in the specified class.
Public Function AutoMap(src_obj, target_obj)
Set AutoMap = FlexMap(src_obj, target_obj, empty)
End Function
'Only maps fields specified in the field_names array (array of strings).
'If field_names is empty, attempts to map all fields from the passed rs or object.
Public Function FlexMap(src_obj, target_obj, field_names)
Set FlexMap = DynMap(src_obj, target_obj, field_names, empty)
End Function
'Only maps fields specified in the field_names array (array of strings).
'If field_names is empty then src MUST be a recordset as it attempts to map all fields from the recordset.
'Since there is no reflection in vbscript, there is no way around this short of pseudo-reflection.
Public Function DynMap(src_obj, target_obj, field_names, exprs)
SetSource src_obj
SetTarget target_obj
dim field_name
dim field_idx 'loop counter
if IsEmpty(field_names) then 'map everything
if typename(src_obj) = "Recordset" then
for field_idx = 0 to src_obj.Fields.Count - 1
field_name = src_obj.Fields.Item(field_idx).Name
'AddStatement field_name
AddStatement BuildStatement(field_name)
next
elseif InStr(typename(src_obj), "Dictionary") > 0 then 'enables Scripting.Dictionary and IRequestDictionary for Request.Querystring and Request.Form
for each field_name in src_obj
AddStatement BuildStatement(field_name)
next
elseif not IsEmpty(src_obj.Class_Get_Properties) then
dim props : props = src_obj.Class_Get_Properties
for field_idx = 0 to ubound(props)
field_name = props(field_idx)
'AddStatement field_name
AddStatement BuildStatement(field_name)
next
else 'some invalid type of object
Err.Raise 9, "Automapper.DynMap", "Cannot automatically map this source object. Expected recordset or object implementing Class_Get_Properties reflection, got: " & typename(src_obj)
end if
else 'map only specified fields
for field_idx = lbound(field_names) to ubound(field_names)
field_name = field_names(field_idx)
'AddStatement field_name
AddStatement BuildStatement(field_name)
next
end if
dim exprs_idx
if not IsEmpty(exprs) then
if typename(exprs) = "Variant()" then
for exprs_idx = lbound(exprs) to ubound(exprs)
'field_name = exprs(exprs_idx)
'AddStatement field_name
AddStatement exprs(exprs_idx)
next
else 'assume string or string-like default value
AddStatement exprs
end if
end if
'Can't pre-join the statements because if one fails the rest of them fail too... :(
'dim joined_statements : joined_statements = Join(m_statements, " : ")
'put joined_statements
'suspend errors to prevent failing when attempting to map a field that does not exist in the class
on error resume next
dim stmt_idx
for stmt_idx = 0 to ubound(m_statements)
Execute m_statements(stmt_idx)
next
on error goto 0
set DynMap = m_target
ResetState
End Function
Private Sub SetSource(ByVal src_obj)
set m_src = src_obj
End Sub
Private Sub SetTarget(ByVal target_obj)
if typename(target_obj) = "String" then
set m_target = eval("new " & target_obj)
else
set m_target = target_obj
end if
End Sub
'Builds a statement and adds it to the internal statements array
Private Sub AddStatement(ByVal stmt)
m_statements_count = m_statements_count + 1
ReDim Preserve m_statements(m_statements_count)
m_statements(m_statements_count) = stmt
End Sub
Private Function BuildStatement(ByVal field_name)
dim result
if typename(m_src) = "Recordset" or InStr(typename(m_src), "Dictionary") > 0 then
result = "m_target." & field_name & " = m_src(""" & field_name & """)"
else
'Funky magic...
'If src.field_name is an object, ensure the set statement is used
if IsObject(eval("m_src." & field_name)) then
result = "set "
else
'result = "m_target." & field_name & " = m_src." & field_name
end if
result = result & " m_target." & field_name & " = m_src." & field_name
end if
BuildStatement = result
End Function
End Class


Function Automapper()
Set Automapper = new Automapper_Class
End Function
%>

+ 155
- 0
core/lib.CDOEmail.asp 查看文件

@@ -0,0 +1,155 @@
<%

' Class: CDOEmail
' Handles email creation and sending via CDO in VBScript
Class CDOEmail_Class
' Public properties
Public From
Public Subject
Public Body
Public IsBodyHTML
Public SMTPServer
Public SMTPPort
Public SMTPUsername
Public SMTPPassword
Public SMTPUseSSL

' Private members
Private cfg
Private msg
Private dictRecipients
Private arrAttachments

' Initialize default values and objects
Private Sub Class_Initialize()
' Create CDO configuration and message objects
Set cfg = Server.CreateObject("CDO.Configuration")
Set msg = Server.CreateObject("CDO.Message")

' Default SMTP settings
SMTPServer = "localhost"
SMTPPort = 25
SMTPUsername = ""
SMTPPassword = ""
SMTPUseSSL = False

' Initialize recipient collections
Set dictRecipients = Server.CreateObject("Scripting.Dictionary")
dictRecipients.Add "TO", Array()
dictRecipients.Add "CC", Array()
dictRecipients.Add "BCC", Array()

' Initialize attachments dynamic array
ReDim arrAttachments(-1)

' Default message settings
From = ""
Subject = ""
Body = ""
IsBodyHTML = False
End Sub

' Add a recipient by type: "To", "Cc", or "Bcc"
Public Sub AddRecipient(recipientType, address)
Dim key, tmp
key = UCase(recipientType)
If Not dictRecipients.Exists(key) Then
Err.Raise vbObjectError + 1000, "CDOEmail", "Invalid recipient type: " & recipientType
End If
tmp = dictRecipients(key)
If UBound(tmp) < LBound(tmp) Then
ReDim tmp(0)
Else
ReDim Preserve tmp(UBound(tmp) + 1)
End If
tmp(UBound(tmp)) = address
dictRecipients(key) = tmp
End Sub

' Add a file attachment
Public Sub AddAttachment(filePath)
If UBound(arrAttachments) < LBound(arrAttachments) Then
ReDim arrAttachments(0)
Else
ReDim Preserve arrAttachments(UBound(arrAttachments) + 1)
End If
arrAttachments(UBound(arrAttachments)) = filePath
End Sub

' Send the email, returning True on success, False on failure
Public Function Send()
' Configure SMTP settings
With cfg.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 ' cdoSendUsingPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = Choice(Len(SMTPUsername) > 0, 1, 0) ' cdoBasic or cdoAnonymous
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SMTPUsername
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SMTPPassword
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = SMTPUseSSL
.Update
End With

' Apply configuration to message
Set msg.Configuration = cfg

' Populate message fields
msg.From = From
msg.Subject = Subject
If dictRecipients.Exists("TO") And UBound(dictRecipients("TO")) >= LBound(dictRecipients("TO")) Then
msg.To = Join(dictRecipients("TO"), ";")
End If
If dictRecipients.Exists("CC") And UBound(dictRecipients("CC")) >= LBound(dictRecipients("CC")) Then
msg.CC = Join(dictRecipients("CC"), ";")
End If
If dictRecipients.Exists("BCC") And UBound(dictRecipients("BCC")) >= LBound(dictRecipients("BCC")) Then
msg.BCC = Join(dictRecipients("BCC"), ";")
End If

If IsBodyHTML Then
msg.HTMLBody = Body
Else
msg.TextBody = Body
End If

' Add attachments if any
Dim i
For i = LBound(arrAttachments) To UBound(arrAttachments)
msg.AddAttachment arrAttachments(i)
Next

' Send and handle errors
On Error Resume Next
msg.Send
errNum = Err.Number
errDesc = Err.Description
On Error Goto 0
If Err.Number <> 0 Then
Response.Write "CDO Error #" & errNum & ": " & errDesc & "<br/>"
Send = False
Err.Clear
Else
Send = True
End If
End Function

' Clean up objects
Private Sub Class_Terminate()
On Error Resume Next
Set msg = Nothing
Set cfg = Nothing
Set dictRecipients = Nothing
Erase arrAttachments
End Sub
End Class

dim CDOEmail_Class__Singleton
Function CDOEmail()
if IsEmpty(CDOEmail_Class__Singleton) then
set CDOEmail_Class__Singleton = new CDOEmail_Class
end if
set CDOEmail = CDOEmail_Class__Singleton
End Function

%>

+ 914
- 0
core/lib.Collections.asp 查看文件

@@ -0,0 +1,914 @@
<%
'=======================================================================================================================
' KVArray
' Relatively painless implementation of key/value pair arrays without requiring a full Scripting.Dictionary COM instance.
' A KVArray is a standard array where element i is the key and element i+1 is the value. Loops must step by 2.
'=======================================================================================================================
'given a KVArray and key index, returns the key and value
'pre: kv_array has at least key_idx and key_idx + 1 values
'post: key and val are populated
Sub KeyVal(kv_array, key_idx, ByRef key, ByRef val)
if (key_idx + 1 > ubound(kv_array)) then err.raise 1, "KeyVal", "expected key_idx < " & ubound(kv_array) - 1 & ", got: " & key_idx
key = kv_array(key_idx)
val = kv_array(key_idx + 1)
End Sub

'---------------------------------------------------------------------------------------------------------------------
'Given a KVArray, a key and a value, appends the key and value to the end of the KVArray
Sub KVAppend(ByRef kv_array, key, val)
dim i : i = ubound(kv_array)
redim preserve kv_array(i + 2)
kv_array(i + 1) = key
kv_array(i + 2) = val
End Sub

'-----------------------------------------------------------------------------------------------------------------------
'Given a KVArray and two variants, populates the first variant with all keys and the second variant with all values.
'If
'Pre: kv_array has at least key_idx and key_idx + 1 values
'Post: key_array contains all keys in kvarray.
' val_array contains all values in kvarray.
' key_array and val_array values are in corresponding order, i.e. key_array(i) corresponds to val_array(i).
Sub KVUnzip(kv_array, key_array, val_array)
dim kv_array_size : kv_array_size = ubound(kv_array)
dim num_pairs : num_pairs = (kv_array_size + 1) / 2
dim result_array_size : result_array_size = num_pairs - 1
'Extend existing key_array or create new array to hold the keys
If IsArray(key_array) then
redim preserve key_array(ubound(key_array) + result_array_size)
Else
key_array = Array()
redim key_array(result_array_size)
End If
'Extend existing val array or create new array to hold the values
If IsArray(val_array) then
redim preserve val_array(ubound(val_array) + result_array_size)
Else
val_array = Array()
redim val_array(num_pairs - 1)
End If
'Unzip the KVArray into the two output arrays
dim i, key, val
dim key_val_arrays_idx : key_val_arrays_idx = 0 ' used to sync loading the key_array and val_array
For i = 0 to ubound(kv_array) step 2
KeyVal kv_array, i, key, val
key_array(key_val_arrays_idx) = key
val_array(key_val_arrays_idx) = val
key_val_arrays_idx = key_val_arrays_idx + 1 ' increment by 1 because loop goes to next pair in kv_array
Next
End Sub

'---------------------------------------------------------------------------------------------------------------------
'Given a KVArray, dumps it to the screen. Useful for debugging purposes.
Sub DumpKVArray(kv_array)
dim i, key, val
For i = 0 to ubound(kv_array) step 2
KeyVal kv_array, i, key, val
put key & " => " & val & "<br>"
Next
End Sub


'=======================================================================================================================
' Pair Class
' Holds a pair of values, i.e. a key value pair, recordset field name/value pair, etc.
' Similar to the C++ STL std::pair class. Useful for some iteration and the like.
'
' This was an interesting idea but so far has not really been used, oh well......
'=======================================================================================================================
Class Pair_Class
Private m_first, m_second

Public Property Get First : First = m_first : End Property
Public Property Get [Second] : [Second] = m_second : End Property
Public Default Property Get TO_String
TO_String = First & " " & [Second]
End Property
Public Sub Initialize(ByVal firstval, ByVal secondval)
Assign m_first, firstval
Assign m_second, secondval
End Sub
'Swaps the two values
Public Sub Swap
dim tmp
Assign tmp, m_second
Assign m_second, m_first
Assign m_first, tmp
End Sub
End Class

Function MakePair(ByVal firstval, ByVal secondval)
dim P : set P = new Pair_Class
P.Initialize firstval, secondval
set MakePair = P
End Function



'=======================================================================================================================
' Linked List - From the Tolerable lib
'=======================================================================================================================
' This is just here for reference
Class Iterator_Class
Public Function HasNext()
End Function
Public Function PeekNext()
End Function
Public Function GetNext()
End Function
Public Function HasPrev()
End Function
Public Function PeekPrev()
End Function
Public Function GetPrev()
End Function
End Class


Class Enumerator_Source_Iterator_Class
Private m_iter
Public Sub Initialize(ByVal iter)
Set m_iter = iter
End Sub
Private Sub Class_Terminate()
Set m_iter = Nothing
End Sub
Public Sub GetNext(ByRef retval, ByRef successful)
If m_iter.HasNext Then
Assign retval, m_iter.GetNext
successful = True
Else
successful = False
End If
End Sub
End Class


Public Function En_Iterator(ByVal iter)
Dim retval
Set retval = New Enumerator_Source_Iterator_Class
retval.Initialize iter
Set En_Iterator = Enumerator(retval)
End Function


Class LinkedList_Node_Class
Public m_prev
Public m_next
Public m_value

Private Sub Class_Initialize()
Set m_prev = Nothing
Set m_next = Nothing
End Sub
Private Sub Class_Terminate()
Set m_prev = Nothing
Set m_next = Nothing
Set m_value = Nothing
End Sub
Public Sub SetValue(ByVal value)
Assign m_value, value
End Sub
End Class


Class Iterator_LinkedList_Class
Private m_left
Private m_right
Public Sub Initialize(ByVal r)
Set m_left = Nothing
Set m_right = r
End Sub
Private Sub Class_Terminate()
Set m_Left = Nothing
Set m_Right = Nothing
End Sub
Public Function HasNext()
HasNext = Not(m_right Is Nothing)
End Function
Public Function PeekNext()
Assign PeekNext, m_right.m_value
End Function
Public Function GetNext()
Assign GetNext, m_right.m_value
Set m_left = m_right
Set m_right = m_right.m_next
End Function
Public Function HasPrev()
HasPrev = Not(m_left Is Nothing)
End Function
Public Function PeekPrev()
Assign PeekPrev, m_left.m_value
End Function
Public Function GetPrev()
Assign GetPrev, m_left.m_value
Set m_right = m_left
Set m_left = m_left.m_prev
End Function
End Class


'-----------------------------------------------------------------------------------------------------------------------
Class LinkedList_Class
Private m_first
Private m_last
Private m_size
Private Sub Class_Initialize()
Me.Reset
End Sub
Private Sub Class_Terminate()
Me.Reset
End Sub
Public Function Clear()
Set m_first = Nothing
Set m_last = Nothing
m_size = 0
Set Clear = Me
End Function
Private Function NewNode(ByVal value)
Dim retval
Set retval = New LinkedList_Node_Class
retval.SetValue value
Set NewNode = retval
End Function
Public Sub Reset()
Set m_first = Nothing
Set m_last = Nothing
m_size = 0
End Sub
Public Function IsEmpty()
IsEmpty = (m_last Is Nothing)
End Function
Public Property Get Count
Count = m_size
End Property
'I just like .Size better than .Count sometimes, sue me
Public Property Get Size
Size = m_size
End Property
Public Function Iterator()
Dim retval
Set retval = New Iterator_LinkedList_Class
retval.Initialize m_first
Set Iterator = retval
End Function
Public Function Push(ByVal value)
Dim temp
Set temp = NewNode(value)
If Me.IsEmpty Then
Set m_first = temp
Set m_last = temp
Else
Set temp.m_prev = m_last
Set m_last.m_next = temp
Set m_last = temp
End If
m_size = m_size + 1
Set Push = Me
End Function


Public Function Peek()
' TODO: Error handling
Assign Peek, m_last.m_value
End Function

' Alias for Peek
Public Function Back()
' TODO: Error handling
Assign Back, m_last.m_value
End Function
Public Function Pop()
Dim temp
' TODO: Error Handling
Assign Pop, m_last.m_value

Set temp = m_last
Set m_last = temp.m_prev
Set temp.m_prev = Nothing
If m_last Is Nothing Then
Set m_first = Nothing
Else
Set m_last.m_next = Nothing
End If
m_size = m_size - 1
End Function



Public Function Unshift(ByVal value)
Dim temp
Set temp = NewNode(value)
If Me.IsEmpty Then
Set m_first = temp
Set m_last = temp
Else
Set temp.m_next = m_first
Set m_first.m_prev = temp
Set m_first = temp
End If
m_size = m_size + 1
Set Unshift = Me
End Function



' Alias for Peek
Public Function Front()
' TODO: Error handling
Assign Front, m_first.m_value
End Function
Public Function Shift()
Dim temp
' TODO: Error Handling
Assign Shift, m_first.m_value

Set temp = m_first
Set m_first = temp.m_next
Set temp.m_next = Nothing
If m_first Is Nothing Then
Set m_last = Nothing
Else
Set m_first.m_prev = Nothing
End If
m_size = m_size - 1
End Function

Public Function TO_Array()
Dim i, iter
ReDim retval(Me.Count - 1)
i = 0
Set iter = Me.Iterator
While iter.HasNext
assign retval(i),iter.GetNext
i = i + 1
Wend
TO_Array = retval
End Function
Public Function TO_En()
Set TO_En = En_Iterator(Iterator)
End Function

End Class




'=======================================================================================================================
' Dynamic Array - From the Tolerable lib
'=======================================================================================================================
Class DynamicArray_Class
Private m_data
Private m_size
Public Sub Initialize(ByVal d, ByVal s)
m_data = d
m_size = s
End Sub
Private Sub Class_Terminate()
Set m_data = Nothing
End Sub
Public Property Get Capacity
Capacity = UBOUND(m_data) + 1
End Property
Public Property Get Count
Count = m_size
End Property
' Alias for Count
Public Property Get Size
Size = m_size
End Property
Public Function IsEmpty()
IsEmpty = (m_size = 0)
End Function
Public Function Clear()
m_size = 0
Set Clear = Me
End Function
Private Sub Grow
' TODO: There's probably a better way to
' do this. Doubling might be excessive
ReDim Preserve m_data(UBOUND(m_data) * 2)
End Sub
Public Function Push(ByVal val)
If m_size >= UBOUND(m_data) Then
Grow
End If
Assign m_data(m_size), val
m_size = m_size + 1
Set Push = Me
End Function
' Look at the last element
Public Function Peek()
Assign Peek, m_data(m_size - 1)
End Function
' Look at the last element and
' pop it off of the list
Public Function Pop()
Assign Pop, m_data(m_size - 1)
m_size = m_size - 1
End Function
' If pseudo_index < 0, then we assume we're counting
' from the back of the Array.
Private Function CalculateIndex(ByVal pseudo_index)
If pseudo_index >= 0 Then
CalculateIndex = pseudo_index
Else
CalculateIndex = m_size + pseudo_index
End If
End Function
Public Default Function Item(ByVal i)
Assign Item, m_data(CalculateIndex(i))
End Function
' This does not treat negative indices as wrap-around.
' Thus, it is slightly faster.
Public Function FastItem(ByVal i)
Assign FastItem, m_data(i)
End Function


Public Function Slice(ByVal s, ByVal e)
s = CalculateIndex(s)
e = CalculateIndex(e)
If e < s Then
Set Slice = DynamicArray()
Else
ReDim retval(e - s)
Dim i, j
j = 0
For i = s to e
Assign retval(j), m_data(i)
j = j + 1
Next
Set Slice = DynamicArray1(retval)
End If
End Function
Public Function Iterator()
Dim retval
Set retval = New Iterator_DynamicArray_Class
retval.Initialize Me
Set Iterator = retval
End Function
Public Function TO_En()
Set TO_En = En_Iterator(Me.Iterator)
End Function
Public Function TO_Array()
Dim i
ReDim retval(m_size - 1)
For i = 0 to UBOUND(retval)
Assign retval(i), m_data(i)
Next
TO_Array = retval
End Function

End Class


Public Function DynamicArray()
ReDim data(3)
Set DynamicArray = DynamicArray2(data, 0)
End Function

Public Function DynamicArray1(ByVal data)
Set DynamicArray1 = DynamicArray2(data, UBOUND(data) + 1)
End Function

Private Function DynamicArray2(ByVal data, ByVal size)
Dim retval
Set retval = New DynamicArray_Class
retval.Initialize data, size
Set DynamicArray2 = retval
End Function


Class Iterator_DynamicArray_Class
Private m_dynamic_array
Private m_index
Public Sub Initialize(ByVal dynamic_array)
Set m_dynamic_array = dynamic_array
m_index = 0
End Sub
Private Sub Class_Terminate
Set m_dynamic_array = Nothing
End Sub
Public Function HasNext()
HasNext = (m_index < m_dynamic_array.Size)
End Function
Public Function PeekNext()
Assign PeekNext, m_dynamic_array.FastItem(m_index)
End Function
Public Function GetNext()
Assign GetNext, m_dynamic_array.FastItem(m_index)
m_index = m_index + 1
End Function
Public Function HasPrev()
HasPrev = (m_index > 0)
End Function
Public Function PeekPrev()
Assign PeekPrev, m_dynamic_array.FastItem(m_index - 1)
End Function
Public Function GetPrev()
Assign GetPrev, m_dynamic_array.FastItem(m_index - 1)
m_index = m_index - 1
End Function
End Class



'=======================================================================================================================
' Other Iterators
'=======================================================================================================================
'!!! EXPERIMENTAL !!! May not be very useful, oh well...
Class Iterator_Recordset_Class
Private m_rs
Private m_record_count
Private m_current_index
Private m_field_names 'cached array
Public Sub Initialize(ByVal rs)
Set m_rs = rs
m_rs.MoveFirst
m_rs.MovePrevious
m_record_count = rs.RecordCount
m_current_index = 0
'cache field names
m_field_names = array()
redim m_field_names(m_rs.Fields.Count)
dim field
dim i : i = 0
for each field in m_rs.Fields
m_field_names(i) = field.Name
next
End Sub
Private Sub Class_Terminate
Set m_rs = Nothing
End Sub
Public Function HasNext()
HasNext = (m_current_index < m_record_count)
put "m_current_index := " & m_current_index
put "m_record_count := " & m_record_count
End Function
Public Function PeekNext
if HasNext then
m_rs.MoveNext
Assign PeekNext, GetPairs
m_rs.MovePrevious
else
set PeekNext = Nothing
end if
End Function
Private Function GetPairs
End Function
Public Function GetNext
if m_current_index < m_record_count then
Assign GetNext, m_rs
m_rs.MoveNext
m_current_index = m_current_index + 1
else
set GetNext = Nothing
end if
End Function
Public Function HasPrev()
if m_rs.BOF then
HasPrev = false
else
m_rs.MovePrevious
HasPrev = Choice(m_rs.BOF, false, true)
m_rs.MoveNext
end if
End Function
Public Function PeekPrev
m_rs.MovePrevious
if m_rs.BOF then
set PeekPrev = Nothing
else
Assign PeekPrev, m_rs
end if
m_rs.MoveNext
End Function
Public Function GetPrev
m_rs.MovePrevious
if m_rs.BOF then
set GetPrev = Nothing
else
Assign GetPrev, m_rs
end if
End Function
End Class


Class Iterator_Dictionary_Class
Private m_dic
Private m_keys 'array
Private m_idx 'current array index
Private m_keys_ubound 'cached ubound(m_keys)
Public Sub Initialize(ByVal dic)
set m_dic = dic
m_keys = m_dic.Keys()
m_idx = -1
m_keys_ubound = ubound(m_keys)
End Sub
Private Sub Class_Terminate
set m_dic = Nothing
End Sub
Public Function HasNext()
HasNext = (m_idx < m_keys_ubound)
End Function
Public Function PeekNext()
Assign PeekNext, m_dic(m_keys(m_idx + 1))
End Function
Public Function GetNext()
Assign GetNext, m_dic(m_keys(m_idx + 1))
m_idx = m_idx + 1
End Function
Public Function HasPrev()
HasPrev = (m_idx > 0)
End Function
Public Function PeekPrev()
Assign PeekPrev, m_dic(m_keys(m_idx - 1))
End Function
Public Function GetPrev()
Assign GetPrev, m_dic(m_keys(m_idx - 1))
m_idx = m_idx - 1
End Function
End Class


'=======================================================================================================================
' Iterator Factory
'=======================================================================================================================
'Returns the appropriate iterator for the passed-in collection. Errors if unknown collection.
Function IteratorFor(col)
dim result
select case typename(col)
case "LinkedList_Class" : set result = new Iterator_LinkedList_Class
case "Dictionary" : set result = new Iterator_Dictionary_Class
case "Recordset" : set result = new Iterator_Recordset_Class
end select
result.Initialize col
set IteratorFor = result
End Function


Class List
Private items
Private P_count

Private Sub Class_Initialize()
ReDim items(-1)
P_count = 0
End Sub

Public Sub Add(value)
ReDim Preserve items(P_count)
If IsObject(value) Then
Set items(P_count) = value
Else
items(P_count) = value
End If
P_count = P_count + 1
End Sub

Public Sub AddRange(arrayToAdd)
Dim i
For i = 0 To UBound(arrayToAdd)
Me.Add arrayToAdd(i)
Next
End Sub

Public Property Get Count()
Count = P_count
End Property

Public Property Get Item(index)
If index < 0 Or index >= P_count Then
Err.Raise 9, "List", "Index out of bounds"
End If
If IsObject(items(index)) Then
Set Item = items(index)
Else
Item = items(index)
End If
End Property

Public Property Let Item(index, value)
If index < 0 Or index >= P_count Then
Err.Raise 9, "List", "Index out of bounds"
End If
If IsObject(value) Then
Set items(index) = value
Else
items(index) = value
End If
End Property

Public Function Contains(ByRef value)
Dim i
For i = 0 To P_count - 1
If IsObject(items(i)) And IsObject(value) Then
If (items(i) Is value) Then
Contains = True
Exit Function
End If
Else
If items(i) = value Then
Contains = True
Exit Function
End If
End If
Next
Contains = False
End Function

Public Function IndexOf(value)
Dim i
For i = 0 To P_count - 1
If IsObject(items(i)) And IsObject(value) Then
If items(i) Is value Then
IndexOf = i
Exit Function
End If
Else
If items(i) = value Then
IndexOf = i
Exit Function
End If
End If
Next
IndexOf = -1
End Function

Public Sub Remove(value)
Dim i
i = Me.IndexOf(value)
If i <> -1 Then
Me.RemoveAt i
End If
End Sub

Public Sub RemoveAt(index)
Dim i
If index < 0 Or index >= P_count Then
Err.Raise 9, "List", "Index out of bounds"
End If

For i = index To P_count - 2
If IsObject(items(i + 1)) Then
Set items(i) = items(i + 1)
Else
items(i) = items(i + 1)
End If
Next

P_count = P_count - 1

If P_count <= 0 Then
ReDim items(-1)
Else
ReDim Preserve items(P_count - 1)
End If
End Sub

Public Sub Clear()
ReDim items(-1)
P_count = 0
End Sub

Public Sub Sort()
Dim i, j, tmp
For i = 0 To P_count - 2
For j = i + 1 To P_count - 1
If CStr(items(i)) > CStr(items(j)) Then
Set tmp = items(i)
Set items(i) = items(j)
Set items(j) = tmp
End If
Next
Next
End Sub

' Note: this will NOT be used automatically by VBScript For Each,
' but you can use it manually.
Public Function New_Enum()
Set New_Enum = New ListEnumerator
New_Enum.Init items, P_count
End Function
End Class


Class ListEnumerator
Private items, index, max

Public Sub Init(arr, cnt)
items = arr
index = -1
max = cnt
End Sub

Public Function MoveNext()
index = index + 1
MoveNext = (index < max)
End Function

Public Property Get Current()
Set Current = items(index)
End Property

Public Sub Reset()
index = -1
End Sub
End Class



%>


+ 110
- 0
core/lib.ControllerRegistry.asp 查看文件

@@ -0,0 +1,110 @@
<%
'=======================================================================================================================
' Controller Registry
' Provides a whitelist of valid controllers to prevent code injection attacks
'=======================================================================================================================

Class ControllerRegistry_Class
Private m_controllers

Private Sub Class_Initialize()
Set m_controllers = Server.CreateObject("Scripting.Dictionary")
m_controllers.CompareMode = 1 ' vbTextCompare for case-insensitive

' Register all valid controllers here
' Format: m_controllers.Add "controllername", True
RegisterController "homecontroller"
RegisterController "errorcontroller"
End Sub

Private Sub Class_Terminate()
Set m_controllers = Nothing
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Register a controller as valid
'---------------------------------------------------------------------------------------------------------------------
Public Sub RegisterController(controllerName)
Dim key : key = LCase(Trim(controllerName))
If Not m_controllers.Exists(key) Then
m_controllers.Add key, True
End If
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Check if a controller is registered (valid)
'---------------------------------------------------------------------------------------------------------------------
Public Function IsValidController(controllerName)
Dim key : key = LCase(Trim(controllerName))
IsValidController = m_controllers.Exists(key)
End Function

'---------------------------------------------------------------------------------------------------------------------
' Get list of all registered controllers
'---------------------------------------------------------------------------------------------------------------------
Public Function GetRegisteredControllers()
GetRegisteredControllers = m_controllers.Keys()
End Function

'---------------------------------------------------------------------------------------------------------------------
' Validate controller name format (alphanumeric and underscore only)
'---------------------------------------------------------------------------------------------------------------------
Public Function IsValidControllerFormat(controllerName)
If IsEmpty(controllerName) Or Len(controllerName) = 0 Then
IsValidControllerFormat = False
Exit Function
End If

Dim i, ch
For i = 1 To Len(controllerName)
ch = Mid(controllerName, i, 1)
' Allow a-z, A-Z, 0-9, and underscore
If Not ((ch >= "a" And ch <= "z") Or _
(ch >= "A" And ch <= "Z") Or _
(ch >= "0" And ch <= "9") Or _
ch = "_") Then
IsValidControllerFormat = False
Exit Function
End If
Next

IsValidControllerFormat = True
End Function

'---------------------------------------------------------------------------------------------------------------------
' Validate action name format (alphanumeric and underscore only)
'---------------------------------------------------------------------------------------------------------------------
Public Function IsValidActionFormat(actionName)
If IsEmpty(actionName) Or Len(actionName) = 0 Then
IsValidActionFormat = False
Exit Function
End If

Dim i, ch
For i = 1 To Len(actionName)
ch = Mid(actionName, i, 1)
' Allow a-z, A-Z, 0-9, and underscore
If Not ((ch >= "a" And ch <= "z") Or _
(ch >= "A" And ch <= "Z") Or _
(ch >= "0" And ch <= "9") Or _
ch = "_") Then
IsValidActionFormat = False
Exit Function
End If
Next

IsValidActionFormat = True
End Function

End Class

' Singleton instance
Dim ControllerRegistry_Class__Singleton
Function ControllerRegistry()
If IsEmpty(ControllerRegistry_Class__Singleton) Then
Set ControllerRegistry_Class__Singleton = New ControllerRegistry_Class
End If
Set ControllerRegistry = ControllerRegistry_Class__Singleton
End Function

%>

+ 29
- 0
core/lib.DAL.asp 查看文件

@@ -0,0 +1,29 @@
<%
' This class encapsulates database access into one location, isolating database details from the rest of the app.
' Multiple databases can be handled in one of two ways:
'
' Option 1. Use a single DAL_Class instance with separate public properties for each database.
' Ex: To access Orders use DAL.Orders and to access Employees use DAL.Employees.
'
' Option 2. Use a separate DAL_Class instance for each database.
' Ex:
' dim OrdersDAL : set OrdersDAL = new DAL_Class
' OrdersDAL.ConnectionString = "..." <-- you would have to create this property to use this approach
'
' If you only access one database it is easier to just set the global DAL singleton to an instance of the
' Database_Class and use it directly. See the example project for details.

'=======================================================================================================================
' DATA ACCESS LAYER Class
'=======================================================================================================================
dim DAL__Singleton : set DAL__Singleton = Nothing

Function DAL()
If DAL__Singleton is Nothing then
set DAL__Singleton = new Database_Class
DAL__Singleton.Initialize GetAppSetting("ConnectionString")

End If
set DAL = DAL__Singleton
End Function
%>

+ 113
- 0
core/lib.Data.asp 查看文件

@@ -0,0 +1,113 @@
<%
Class Database_Class
Private m_connection
Private m_connection_string
Private m_trace_enabled
Public Sub set_trace(bool) : m_trace_enabled = bool : End Sub
Public Property Get is_trace_enabled : is_trace_enabled = m_trace_enabled : End Property
'---------------------------------------------------------------------------------------------------------------------
Public Sub Initialize(connection_string)
m_connection_string = connection_string
End Sub

'---------------------------------------------------------------------------------------------------------------------
Public Function ShapeQuery(sql,params)
dim shapeConn : set shapeConn = server.createobject("adodb.connection")
shapeConn.ConnectionString = "Provider=MSDataShape;Data " & m_connection_string
dim cmd : set cmd = server.createobject("adodb.command")
shapeConn.open
set cmd.ActiveConnection = shapeConn
cmd.CommandText = sql
dim rs
If IsArray(params) then
set rs = cmd.Execute(, params)
ElseIf Not IsEmpty(params) then ' one parameter
set rs = cmd.Execute(, Array(params))
Else
set rs = cmd.Execute()
End If
set ShapeQuery = rs
End Function

Public Function Query(sql, params)
dim cmd : set cmd = server.createobject("adodb.command")
set cmd.ActiveConnection = Connection
cmd.CommandText = sql
dim rs
If IsArray(params) then
set rs = cmd.Execute(, params)
ElseIf Not IsEmpty(params) then ' one parameter
set rs = cmd.Execute(, Array(params))
Else
set rs = cmd.Execute()
End If
set Query = rs
End Function
'---------------------------------------------------------------------------------------------------------------------
Public Function PagedQuery(sql, params, per_page, page_num)
dim cmd : set cmd = server.createobject("adodb.command")
set cmd.ActiveConnection = Connection
cmd.CommandText = sql
cmd.CommandType = 1 'adCmdText
cmd.ActiveConnection.CursorLocation = 3 'adUseClient
dim rs
If IsArray(params) then
set rs = cmd.Execute(, params)
ElseIf Not IsEmpty(params) then ' one parameter
set rs = cmd.Execute(, Array(params))
Else
set rs = cmd.Execute()
End If
If Not rs.EOF then
rs.PageSize = 1
rs.CacheSize = 1
rs.AbsolutePage = 1
End If
set PagedQuery = rs
End Function
'---------------------------------------------------------------------------------------------------------------------
Public Sub [Execute](sql, params)
me.query sql, params
End Sub
'---------------------------------------------------------------------------------------------------------------------
Public Sub BeginTransaction
Connection.BeginTrans
End Sub
Public Sub RollbackTransaction
Connection.RollbackTrans
End Sub
Public Sub CommitTransaction
Connection.CommitTrans
End Sub
'---------------------------------------------------------------------------------------------------------------------
' Private Methods
'---------------------------------------------------------------------------------------------------------------------
Private Sub Class_terminate
Destroy m_connection
End Sub
Public Function Connection
if not isobject(m_connection) then
set m_connection = Server.CreateObject("adodb.connection")
m_connection.open m_connection_string
end if
set Connection = m_connection
End Function
end Class
%>

+ 202
- 0
core/lib.Enumerable.asp 查看文件

@@ -0,0 +1,202 @@
<%
Class EnumerableHelper_Class
Private m_list

Public Sub Init(list)
set m_list = list
End Sub

Public Sub Class_Terminate
set m_list = Nothing
End Sub

Public Default Function Data()
set Data = m_list
End Function


'---------------------------------------------------------------------------------------------------------------------
' Convenience wrappers
'---------------------------------------------------------------------------------------------------------------------
Public Function Count()
Count = m_list.Count()
End Function

Public Function First()
Assign First, m_list.Front()
End Function

Public Function Last()
Assign Last, m_list.Back()
End Function

'---------------------------------------------------------------------------------------------------------------------
' Methods that return a single value
'---------------------------------------------------------------------------------------------------------------------

'true if all elements of the list satisfy the condition
Public Function All(condition)
dim item_, all_matched : all_matched = true
dim it : set it = m_list.Iterator
Do While it.HasNext
Assign item_, it.GetNext()
If "String" = typename(condition) then
If Not eval(condition) then
all_matched = false
End If
Else
If Not condition(item_) then
all_matched = false
End If
End If
If Not all_matched then Exit Do
Loop
All = all_matched
End Function

'true if any element of the list satisfies the condition
Public Function Any(condition)
Any = Not All("Not " & condition)
End Function
Public Function Max(expr)
dim V_, item_, maxval
dim it : set it = m_list.Iterator
If "String" = typename(expr) then
While it.HasNext
Assign item_, it.GetNext()
Assign V_, eval(expr)
If V_ > maxval then maxval = V_
Wend
Else
While it.HasNext
Assign item_, it.GetNext()
Assign V_, expr(item_)
If V_ > maxval then maxval = V_
Wend
End If
Max = maxval
End Function

Public Function Min(expr)
dim V_, item_, minval
dim it : set it = m_list.Iterator
If "String" = typename(expr) then
While it.HasNext
Assign item_, it.GetNext()
If IsEmpty(minval) then ' empty is always less than everything so set it on first pass
Assign minval, item_
End If
Assign V_, eval(expr)
If V_ < minval then minval = V_
Wend
Else
While it.HasNext
Assign item_, it.GetNext()
If IsEmpty(minval) then
Assign minval, item_
End If
V_ = expr(item_)
If V_ < minval then minval = V_
Wend
End If
Min = minval
End Function

Public Function Sum(expr)
dim V_, item_
dim it : set it = m_list.Iterator
While it.HasNext
Assign item_, it.GetNext()
execute "V_ = V_ + " & expr
Wend
Sum = V_
End Function


'---------------------------------------------------------------------------------------------------------------------
' Methods that return a new instance of this class
'---------------------------------------------------------------------------------------------------------------------

'returns a list that results from running lambda_or_proc once for every element in the list
Public Function Map(lambda_or_proc)
dim list2 : set list2 = new LinkedList_Class
dim it : set it = m_list.Iterator
dim item_
If "String" = typename(lambda_or_proc) then
dim V_
While it.HasNext
Assign item_, it.GetNext()
execute lambda_or_proc
list2.Push V_
Wend
Else
While it.HasNext
Assign item_, it.GetNext()
list2.Push lambda_or_proc(item_)
Wend
End If
set Map = Enumerable(list2)
End Function

'alias to match IEnumerable for convenience
Public Function [Select](lambda_or_proc)
set [Select] = Map(lambda_or_proc)
End Function

'returns list containing first n items
Public Function Take(n)
dim list2 : set list2 = new LinkedList_Class
dim it : set it = m_list.Iterator
dim i : i = 1
While it.HasNext And i <= n
list2.Push it.GetNext()
i = i + 1
Wend
set Take = Enumerable(list2)
End Function

'returns list containing elements as long as the condition is true, and skips the remaining elements
Public Function TakeWhile(condition)
dim list2 : set list2 = new LinkedList_Class
dim item_, V_, bln
dim it : set it = m_list.Iterator
Do While it.HasNext
Assign item_, it.GetNext()
If "String" = typename(condition) then
'execute condition
If Not eval(condition) then Exit Do
Else
If Not condition(item_) then Exit Do
End If
list2.Push item_
Loop
set TakeWhile = Enumerable(list2)
End Function
'returns a list containing only elements that satisfy the condition
Public Function Where(condition)
dim list2 : set list2 = new LinkedList_Class
dim it : set it = m_list.Iterator
dim item_
While it.HasNext
Assign item_, it.GetNext()
If "String" = typename(condition) then
If eval(condition) then list2.Push item_
Else
If condition(item_) then list2.Push item_
End If
Wend
set Where = Enumerable(list2)
End Function

End Class


Function Enumerable(list)
dim E : set E = new EnumerableHelper_Class
E.Init list
set Enumerable = E
End Function
%>

+ 178
- 0
core/lib.ErrorHandler.asp 查看文件

@@ -0,0 +1,178 @@
<%
'=======================================================================================================================
' Error Handler Library
' Provides centralized error handling and logging functionality
'=======================================================================================================================

Class ErrorHandler_Class
Private m_log_to_file
Private m_log_file_path

Private Sub Class_Initialize()
m_log_to_file = False
m_log_file_path = ""
End Sub

' Configure whether to log errors to file
Public Property Let LogToFile(value)
m_log_to_file = value
End Property

Public Property Get LogToFile()
LogToFile = m_log_to_file
End Property

' Set the log file path
Public Property Let LogFilePath(value)
m_log_file_path = value
End Property

Public Property Get LogFilePath()
LogFilePath = m_log_file_path
End Property

'---------------------------------------------------------------------------------------------------------------------
' Main error handling method
' context: String describing where the error occurred
' errObj: VBScript Err object (optional, uses global Err if not provided)
'---------------------------------------------------------------------------------------------------------------------
Public Sub HandleError(context, errObj)
Dim isDevelopment
isDevelopment = (LCase(GetAppSetting("Environment")) = "development")

If IsEmpty(errObj) Or Not IsObject(errObj) Then
' Use global Err object if none provided
If Err.Number <> 0 Then
If isDevelopment Then
ShowDetailedError context, Err
Else
ShowGenericError
End If
LogError context, Err
End If
Else
If errObj.Number <> 0 Then
If isDevelopment Then
ShowDetailedError context, errObj
Else
ShowGenericError
End If
LogError context, errObj
End If
End If
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Display detailed error information (Development mode only)
'---------------------------------------------------------------------------------------------------------------------
Private Sub ShowDetailedError(context, errObj)
Dim errHtml
errHtml = "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; font-family:Verdana,sans-serif; font-size:14px; border-radius:4px;'>"
errHtml = errHtml & "<strong>Error Occurred</strong><br>"

If Not IsEmpty(context) And Len(context) > 0 Then
errHtml = errHtml & "<strong>Context:</strong> " & Server.HTMLEncode(context) & "<br>"
End If

errHtml = errHtml & "<strong>Time:</strong> " & Now() & "<br>"
errHtml = errHtml & "<strong>Number:</strong> " & errObj.Number & "<br>"
errHtml = errHtml & "<strong>Description:</strong> " & Server.HTMLEncode(errObj.Description) & "<br>"

If Len(errObj.Source) > 0 Then
errHtml = errHtml & "<strong>Source:</strong> " & Server.HTMLEncode(errObj.Source) & "<br>"
End If

errHtml = errHtml & "</div>"
Response.Write errHtml
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Display generic error message (Production mode)
'---------------------------------------------------------------------------------------------------------------------
Private Sub ShowGenericError()
Dim errHtml
errHtml = "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; font-family:Verdana,sans-serif; font-size:14px; border-radius:4px;'>"
errHtml = errHtml & "<strong>An error occurred</strong><br>"
errHtml = errHtml & "We apologize for the inconvenience. The error has been logged and will be investigated.<br>"
errHtml = errHtml & "Please try again later or contact support if the problem persists."
errHtml = errHtml & "</div>"
Response.Write errHtml
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Log error to file (if enabled)
'---------------------------------------------------------------------------------------------------------------------
Private Sub LogError(context, errObj)
If Not m_log_to_file Or Len(m_log_file_path) = 0 Then Exit Sub

On Error Resume Next
Dim fso, logFile, logEntry

Set fso = Server.CreateObject("Scripting.FileSystemObject")

' Create log entry
logEntry = "[" & Now() & "] "
If Len(context) > 0 Then
logEntry = logEntry & "Context: " & context & " | "
End If
logEntry = logEntry & "Error #" & errObj.Number & ": " & errObj.Description

If Len(errObj.Source) > 0 Then
logEntry = logEntry & " | Source: " & errObj.Source
End If

logEntry = logEntry & vbCrLf

' Append to log file
If fso.FileExists(m_log_file_path) Then
Set logFile = fso.OpenTextFile(m_log_file_path, 8, False) ' 8 = ForAppending
Else
Set logFile = fso.CreateTextFile(m_log_file_path, True)
End If

logFile.Write logEntry
logFile.Close
Set logFile = Nothing
Set fso = Nothing

On Error GoTo 0
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Quick check if an error exists
'---------------------------------------------------------------------------------------------------------------------
Public Function HasError()
HasError = (Err.Number <> 0)
End Function

'---------------------------------------------------------------------------------------------------------------------
' Clear the current error
'---------------------------------------------------------------------------------------------------------------------
Public Sub ClearError()
Err.Clear
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Check and handle error in one call
'---------------------------------------------------------------------------------------------------------------------
Public Function CheckAndHandle(context)
If Err.Number <> 0 Then
HandleError context, Err
CheckAndHandle = True
Else
CheckAndHandle = False
End If
End Function

End Class

' Singleton instance
Dim ErrorHandler_Class__Singleton
Function ErrorHandler()
If IsEmpty(ErrorHandler_Class__Singleton) Then
Set ErrorHandler_Class__Singleton = New ErrorHandler_Class
End If
Set ErrorHandler = ErrorHandler_Class__Singleton
End Function

%>

+ 151
- 0
core/lib.Flash.asp 查看文件

@@ -0,0 +1,151 @@
<%
'=======================================================================================================================
' Flash Message Class
'=======================================================================================================================
Class Flash_Class
Private m_errors_key
Private m_success_key

Private Sub Class_Initialize
' Use constants to avoid typos
m_errors_key = "mvc.flash.errors_array"
m_success_key = "mvc.flash.success_message"
End Sub
'helper methods to avoid if..then statements in views
Public Sub ShowErrorsIfPresent
if HasErrors then ShowErrors
End Sub
Public Sub ShowSuccessIfPresent
if HasSuccess then ShowSuccess
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Errors
'---------------------------------------------------------------------------------------------------------------------
Public Property Get HasErrors
HasErrors = (Not IsEmpty(Session(m_errors_key)))
End Property

Public Property Get Errors
Errors = Session(m_errors_key)
End Property
Public Property Let Errors(ary)
Session(m_errors_key) = ary
End Property
Public Sub AddError(msg)
dim ary
if IsEmpty(Session(m_errors_key)) then
ary = Array()
redim ary(-1)
else
ary = Session(m_errors_key)
end if
redim preserve ary(ubound(ary) + 1)
ary(ubound(ary)) = msg
Session(m_errors_key) = ary
End Sub
'Public Sub ShowErrors
' ClearErrors
'End Sub
Public Sub ShowErrors
if HasErrors then
%>
<div id="flashErrorBox" class="alert alert-danger alert-dismissible fade show" role="alert">
<strong>Error!</strong>
<ul class="mb-0 mt-2">
<%
dim ary, i
ary = Errors
for i = 0 to ubound(ary)
put "<li>"
put H(ary(i))
put "</li>"
next
%>
</ul>
<button type="button" class="btn-close" data-bs-dismiss="alert" aria-label="Close"></button>
</div>
<script>
(function() {
var timeout = <%= GetAppSetting("FlashMessageTimeout") %>;
if (isNaN(timeout) || timeout <= 0) timeout = 3000;

setTimeout(function() {
var alertEl = document.getElementById("flashErrorBox");
if (alertEl && typeof bootstrap !== 'undefined') {
var bsAlert = bootstrap.Alert.getOrCreateInstance(alertEl);
bsAlert.close();
} else if (alertEl) {
alertEl.style.display = "none";
}
}, timeout);
})();
</script>
<%
ClearErrors
end if
End Sub
Public Sub ClearErrors
Session.Contents.Remove(m_errors_key)
End Sub
'---------------------------------------------------------------------------------------------------------------------
' Success
'---------------------------------------------------------------------------------------------------------------------
Public Property Get HasSuccess
HasSuccess = (Not IsEmpty(Session(m_success_key)))
End Property
Public Property Get Success
Success = Session(m_success_key)
End Property
Public Property Let Success(msg)
Session(m_success_key) = msg
End Property
Public Sub ShowSuccess
if HasSuccess then
%>
<div id="flashSuccessBox" class="alert alert-success alert-dismissible fade show" role="alert">
<%= H(Success) %>
<button type="button" class="btn-close" data-bs-dismiss="alert" aria-label="Close"></button>
</div>
<script>
(function() {
var timeout = <%= GetAppSetting("FlashMessageTimeout") %>;
if (isNaN(timeout) || timeout <= 0) timeout = 3000;

setTimeout(function() {
var alertEl = document.getElementById("flashSuccessBox");
if (alertEl && typeof bootstrap !== 'undefined') {
var bsAlert = bootstrap.Alert.getOrCreateInstance(alertEl);
bsAlert.close();
} else if (alertEl) {
alertEl.style.display = "none";
}
}, timeout);
})();
</script>
<%
ClearSuccess
end if
End Sub
Public Sub ClearSuccess
Session.Contents.Remove(m_success_key)
End Sub
End Class

Function Flash()
set Flash = new Flash_Class
End Function
%>

+ 79
- 0
core/lib.FormCache.asp 查看文件

@@ -0,0 +1,79 @@
<%
Class FormCache_Class
'given a form name and IRequestDictionary params (request.form) object, caches form values
Public Sub SerializeForm(form_name, params)
dim form_key, form_val, serialized_key
For Each form_key in params
form_val = params(form_key)
serialized_key = CachedFormKeyName(form_name, form_key)
'put "serialize<br>"
'put "--form_key := " & form_key & "<br>"
'put "--form_val := " & form_val & "<br>"
'put "--serialized_key := " & serialized_key & "<br>"
Session(serialized_key) = form_val
Next
End Sub
'given a form name, returns a dict with the form's stored values
Public Function DeserializeForm(form_name)
dim dict : set dict = Nothing
dim serialized_key, serialized_val, form_key, form_val
For Each serialized_key in Session.Contents
'put "serialized_key: " & serialized_key & "<br>"
If InStr(serialized_key, "mvc.form." & form_name) > 0 then
'put "--match" & "<br>"
If dict Is Nothing then
set dict = Server.CreateObject("Scripting.Dictionary")
'put "dict created<br>"
End If
form_val = Session(serialized_key)
form_key = Replace(serialized_key, "mvc.form." & form_name & ".", "")
dict(form_key) = form_val
'Session.Contents.Remove serialized_key
'put "--serialized_val: " & serialized_val & "<br>"
'put "--form_val: " & form_val & "<br>"
End If
Next
set DeserializeForm = dict
End Function
'given a form name, clears the keys for that form
Public Sub ClearForm(form_name)
Dim key, prefix, keysToRemove(), idx

prefix = "mvc.form." & form_name & "."
ReDim keysToRemove(-1)

' First collect the keys to remove
For Each key In Session.Contents
If Left(CStr(key), Len(prefix)) = prefix Then
ReDim Preserve keysToRemove(UBound(keysToRemove) + 1)
keysToRemove(UBound(keysToRemove)) = key
End If
Next

' Then remove them
For idx = 0 To UBound(keysToRemove)
Session.Contents.Remove keysToRemove(idx)
Next
End Sub

Private Function CachedFormKeyName(form_name, key)
CachedFormKeyName = "mvc.form." & form_name & "." & key
End Function
End Class


dim FormCache__Singleton
Function FormCache()
if IsEmpty(FormCache__Singleton) then
set FormCache__Singleton = new FormCache_Class
end if
set FormCache = FormCache__Singleton
End Function
%>

+ 77
- 0
core/lib.HTML.Security.asp 查看文件

@@ -0,0 +1,77 @@
<%
'=======================================================================================================================
' HTML SECURITY HELPER
'=======================================================================================================================
Class HTML_Security_Helper_Class

'---------------------------------------------------------------------------------------------------------------------
'Uses Scriptlet.TypeLib to generate a GUID. There may be a better/faster way than this to generate a nonce.
Public Function Nonce()
dim TL : set TL = CreateObject("Scriptlet.TypeLib")
Nonce = Left(CStr(TL.Guid), 38) 'avoids issue w/ strings appended after this token not being displayed on screen, MSFT bug
set TL = Nothing
End Function
'---------------------------------------------------------------------------------------------------------------------
'Name is probably the combined ControllerName and ActionName of the form generator by convention
Public Sub SetAntiCSRFToken(name)
Session(name & ".anti_csrf_token") = Nonce()
End Sub
'---------------------------------------------------------------------------------------------------------------------
'Returns the CSRF token nonce from the session corresponding to the passed name
Public Function GetAntiCSRFToken(name)
dim token : token = Session(name & ".anti_csrf_token")
If Len(token) = 0 or IsEmpty(token) then
SetAntiCSRFToken name
End If
GetAntiCSRFToken = token
End Function
'---------------------------------------------------------------------------------------------------------------------
'Removes the current CSRF token nonce for the passed name
Public Sub ClearAntiCSRFToken(name)
Session.Contents.Remove(name & ".anti_csrf_token")
End Sub
'---------------------------------------------------------------------------------------------------------------------
'Returns true if passed nonce matches the stored CSRF token nonce for the specified name, false if not
Public Function IsValidAntiCSRFToken(name, nonce)
IsValidAntiCSRFToken = (GetAntiCSRFToken(name) = nonce)
End Function
'---------------------------------------------------------------------------------------------------------------------
'If an invalid CSRF nonce is passed, sets the flash and redirects using the appropriate MVC.Redirect* method.
'If a valid CSRF nonce is passed, clears it from the cache to reset the state to the beginning.
Public Sub OnInvalidAntiCSRFTokenRedirectToAction(token_name, token, action_name)
OnInvalidAntiCSRFTokenRedirectToExt token_name, token, MVC.ControllerName, action_name, empty
End Sub
Public Sub OnInvalidAntiCSRFTokenRedirectToActionExt(token_name, token, action_name, params)
OnInvalidAntiCSRFTokenRedirectToExt token_name, token, MVC.ControllerName, action_name, params
End Sub
Public Sub OnInvalidAntiCSRFTokenRedirectTo(token_name, token, controller_name, action_name)
OnInvalidAntiCSRFTokenRedirectToExt token_name, token, controller_name, action_name
End Sub
Public Sub OnInvalidAntiCSRFTokenRedirectToExt(token_name, token, controller_name, action_name, params)
If IsValidAntiCSRFToken(token_name, token) then
ClearAntiCSRFToken token_name
Else
ClearAntiCSRFToken token_name
Flash.AddError "Invalid form state. Please try again."
MVC.RedirectToExt controller_name, action_name, params
End If
End Sub
End Class


dim HTML_Security_Helper__Singleton
Function HTMLSecurity()
If IsEmpty(HTML_Security_Helper__Singleton) Then
set HTML_Security_Helper__Singleton = new HTML_Security_Helper_Class
End If
set HTMLSecurity = HTML_Security_Helper__Singleton
End Function
%>

+ 282
- 0
core/lib.HTML.asp 查看文件

@@ -0,0 +1,282 @@
<%
'=======================================================================================================================
' HTML HELPER
'=======================================================================================================================
Class HTML_Helper_Class
'Duplicate of Routes.NoCacheToken, copied to avoid extra lookup into the Routes object for such a trivial function.
'Allows caller to reference HTML.NoCacheToken in cases where it seems to feel right.
Public Property Get NoCacheToken
NoCacheToken = Timer() * 100
End Property
'Ensures safe output
Public Function Encode(ByVal value)
If Not IsEmpty(value) and Not IsNull(value) then
Encode = Server.HtmlEncode(value)
End If
End Function

'---------------------------------------------------------------------------------------------------------------------
'LinkTo and its relatives DO NOT HTMLEncode the link_text! This allows use of HTML within the link, especially
'useful for Bootstrap icons and the like.
'
'Bottom Line: If you need to HTMLEncode the link text YOU MUST DO IT YOURSELF! The H() method makes this easy!
Public Function LinkTo(link_text, controller_name, action_name)
LinkTo = LinkToExt(link_text, controller_name, action_name, empty, empty)
End Function

Public Function LinkToExt(link_text, controller_name, action_name, params_array, attribs_array)
LinkToExt = "<a href='" & Encode(Routes.UrlTo(controller_name, action_name, params_array)) & "'" &_
HtmlAttribs(attribs_array) & ">" & link_text & "</a>" & vbCR
End Function
Public Function LinkToIf(condition, link_text, controller_name, action_name)
if condition then
LinkToIf = LinkToExt(link_text, controller_name, action_name, empty, empty)
end if
End Function
Public Function LinkToExtIf(condition, link_text, controller_name, action_name, params_array, attribs_array)
if condition then
LinkToExtIf = LinkToExt(link_text, controller_name, action_name, params_array, attribs_array)
end if
End Function
Public Function LinkToUnless(condition, link_text, controller_name, action_name)
if not condition then
LinkToIf = LinkToExt(link_text, controller_name, action_name, empty, empty)
end if
End Function
Public Function LinkToExtUnless(condition, link_text, controller_name, action_name, params_array, attribs_array)
if not condition then
LinkToExtUnless = LinkToExt(link_text, controller_name, action_name, params_array, attribs_array)
end if
End Function
''
' Creates a form button and a hidden form to enforce POST submissions. Params are in hidden fields.
''
'Public Function PostButtonLinkTo(controller_name, action_name, params)
' dim id : id = "post_button__" & controller_name & action_name
' dim s
' s = "<form id='" & id & "' action='" & Routes.UrlTo(controller_name, action_name, empty) & "' method='POST'>"
' dim i, key, val
' for i = 0 to ubound(params) step 2
' KeyVal params, i, key, val
' s = s & "<input type='hidden' name='" & key & "' value='" & val & "'>"
' next
' s = s & "<input type='submit' value='&gt;&gt;'>"
' s = s & "</form>"
' PostButtonLinkTo = s
'End Function
Public Function PostButtonTo(button_contents, controller_name, action_name, form_fields)
PostButtonTo = PostButtonToExt(button_contents, controller_name, action_name, form_fields, empty)
End Function
Public Function PostButtonToExt(button_contents, controller_name, action_name, form_fields, url_params)
dim s : s = "<form action='" & Routes.UrlTo(controller_name, action_name, url_params) & "' method='POST' style='margin: 0;'>"
dim i, key, val
for i = 0 to ubound(form_fields) step 2
KeyVal form_fields, i, key, val
s = s & HTML.Hidden(key, val)
next
s = s & HTML.SubmitButton(button_contents)
s = s & "</form>" & vbCR
PostButtonToExt = s
End Function
Public Function AppStylesheetTag
AppStylesheetTag = StylesheetTag(Routes.StylesheetsURL & "App.css")
End Function
Public Function ControllerStylesheetTag
ControllerStylesheetTag = StylesheetTag(Routes.StylesheetsUrl & MVC.ControllerName & "Controller.css")
End Function
Public Function StylesheetTag(url)
StylesheetTag = "<link rel='stylesheet' href='" & Encode(url) & "?" & Year(now) & Month(now) & Day(now) & Hour(now) & Minute(now) & Second(now) & "'>" & vbCR
End Function
Public Function JSTag(url)
JSTag = "<script type='text/javascript' src='" & Encode(url) & "'></script>" & vbCR
End Function
'---------------------------------------------------------------------------------------------------------------------
' Form Helpers
'---------------------------------------------------------------------------------------------------------------------
Public Function FormTag(controller_name, action_name, route_attribs, form_attribs)
FormTag = "<form action='" & Routes.UrlTo(controller_name, action_name, route_attribs) & "' method='POST' " & HtmlAttribs(form_attribs) & ">" & vbCR
End Function
Public Function Label(name, for_name)
Label = LabelExt(name, for_name, empty)
End Function
Public Function LabelExt(name, for_name, attribs)
LabelExt = "<label for='" & Encode(for_name) & "' " & HtmlAttribs(attribs) & ">" & Encode(name) & "</label>" & vbCR
End Function
Public Function Hidden(id, value)
Hidden = HiddenExt(id, value, empty)
End Function
Public Function HiddenExt(id, value, attribs)
HiddenExt = "<input type='hidden' id='" & Encode(id) & "' name='" & Encode(id) & "' value='" & Encode(value) & "' " & HtmlAttribs(attribs) & " >" & vbCR
End Function
Public Function TextBox(id, value)
TextBox = TextBoxExt(id, value, empty)
End Function
Public Function TextBoxExt(id, value, attribs)
TextBoxExt = "<input type='text' id='" & Encode(id) & "' name='" & Encode(id) & "' value='" & Encode(value) & "' " & HtmlAttribs(attribs) & " >" & vbCR
End Function
Public Function TextArea(id, value, rows, cols)
TextArea = TextAreaExt(id, value, rows, cols, empty)
End Function
Public Function TextAreaExt(id, value, rows, cols, attribs)
TextAreaExt = "<textarea id='" & Encode(id) & "' name='" & Encode(id) & "' cols='" & Encode(cols) & "' rows='" & Encode(rows) & "' " & HtmlAttribs(attribs) & " >" &_
Encode(value) & "</textarea>" & vbCR
End Function
'---------------------------------------------------------------------------------------------------------------------
'If list is a recordset then option_value_field and option_text_field are required.
'If list is an array the method assumes it is a KVArray and those parameters are ignored.
Public Function DropDownList(id, selected_value, list, option_value_field, option_text_field)
DropDownList = DropDownListExt(id, selected_value, list, option_value_field, option_text_field, empty)
End Function
Public Function DropDownListExt(id, selected_value, list, option_value_field, option_text_field, attribs)
If IsNull(selected_value) then
selected_value = ""
Else
selected_value = CStr(selected_value)
End If
dim item, options, opt_val, opt_txt
options = "<option value=''>" ' first value is "non-selected" blank state
select case typename(list)
case "Recordset"
do until list.EOF
If IsNull(list(option_value_field)) then
opt_val = ""
Else
opt_val = CStr(list(option_value_field))
End If
opt_txt = list(option_text_field)
If Not IsNull(opt_val) And Not IsEmpty(opt_val) then
options = options & "<option value='" & Encode(opt_val) & "' " & Choice((CStr(opt_val) = CStr(selected_value)), "selected='selected'", "") & ">" & Encode(opt_txt) & "</option>" & vbCR
End If
list.MoveNext
loop
case "Variant()" 'assumes KVArray
dim i
for i = 0 to ubound(list) step 2
KeyVal list, i, opt_val, opt_txt
options = options & "<option value='" & Encode(opt_val) & "' " & Choice((CStr(opt_val) = CStr(selected_value)), "selected='selected'", "") & ">" & Encode(opt_txt) & "</option>" & vbCR
next
end select
DropDownListExt = "<select id='" & Encode(id) & "' name='" & Encode(id) & "' " & HtmlAttribs(attribs) & " >" & vbCR & options & "</select>" & vbCR
End Function
Public Function Checkbox(id, value)
Checkbox = CheckboxExt(id, value, empty)
End Function
Public Function CheckboxExt(id, value, attribs)
CheckBoxExt = "<input type='checkbox' id='" & Encode(id) & "' name='" & Encode(id) & "' " & Choice( (value = 1) or (value = true) or (LCase(value) = "true") or (LCase(value) = "on"), "checked='checked'", "") & " " & HtmlAttribs(attribs) & ">" & vbCR
End Function
'---------------------------------------------------------------------------------------------------------------------
'Button text IS NOT ENCODED! As with LinkTo, this allows use of Bootstrap icons and other arbitrary HTML in the
'button. If you need to HTMLEncode the text you MUST do it yourself!
Public Function SubmitButton(text)
SubmitButton = "<button type='submit' class='btn'>" & text & "</button>" & vbCR
End Function
Public Function Button(button_type, text, class_name)
Button = "<button type='" & Encode(button_type) & "' class='btn " & Encode(class_name) & "'>" & text & "</button>" & vbCR
End Function
Public Function ButtonExt(button_type, text, attribs_array)
ButtonExt = "<button type='" & Encode(button_type) & "' " & HtmlAttribs(attribs_array) & ">" & text & "</button>" & vbCR
End Function
'---------------------------------------------------------------------------------------------------------------------
Public Function Tag(Tag_name, attribs_array)
Tag = "<" & Encode(tag_name) & " " & HtmlAttribs(attribs_array) & ">"
End Function
Public Function Tag_(Tag_name)
Tag_ = "</" & Encode(tag_name) & ">"
End Function
'---------------------------------------------------------------------------------------------------------------------
Public Function HtmlAttribs(attribs)
dim result : result = ""
if not IsEmpty(attribs) then
if IsArray(attribs) then
dim idx
for idx = lbound(attribs) to ubound(attribs) step 2
result = result & " " & HtmlAttrib(attribs, idx) & " "
next
else ' assume string or string-like default value
result = attribs
end if
end if
HtmlAttribs = result
End Function
Public Function HtmlAttrib(attribs_array, key_idx)
dim key, val
KeyVal attribs_array, key_idx, key, val
HtmlAttrib = Encode(key) & "='" & Encode(val) & "'"
End Function
Function checkboxfor(fieldName, isChecked)
Dim idSuffix, checkboxId, html

' Decide on the id suffix and checked attribute
If isChecked Then
idSuffix = "Checked"
Else
idSuffix = "Default"
End If

checkboxId = "flexSwitchCheck" & idSuffix

' Build the HTML string
html = "<div class='form-check form-switch'>" & vbCrLf
html = html & " <input class='form-check-input form-control' type='checkbox' id='" & checkboxId & "' name='" & fieldName & "'"
If isChecked Then html = html & " checked"
html = html & ">" & vbCrLf
html = html & " <label class='form-check-label' for='" & checkboxId & "'>" & fieldName & "</label>" & vbCrLf
html = html & "</div>"

checkboxfor = html
End Function


End Class


dim HTML_Helper__Singleton : set HTML_Helper__Singleton = Nothing
Function HTML()
if HTML_Helper__Singleton Is Nothing then
set HTML_Helper__Singleton = new HTML_Helper_Class
End if
set HTML = HTML_Helper__Singleton
End Function


%>

+ 439
- 0
core/lib.Migrations.asp 查看文件

@@ -0,0 +1,439 @@
<%
'=======================================================================================================================
' MIGRATION SYSTEM
'=======================================================================================================================
' Provides database migration capabilities for version-controlled schema changes.
'
' Features:
' - Sequential migration versioning (timestamp-based)
' - Up/Down migration support
' - Migration tracking in schema_migrations table
' - Transaction support for atomic migrations
' - Migration status checking
'
' Usage:
' Set migrator = Migrator()
' migrator.ApplyMigration "20260109120000_create_users_table.asp"
' migrator.RollbackMigration "20260109120000_create_users_table.asp"
' pending = migrator.GetPendingMigrations()
' applied = migrator.GetAppliedMigrations()
'

Class Migrator_Class
Private m_db
Private m_migrations_path
Private m_schema_table

'-------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
Set m_db = DAL()
m_schema_table = "schema_migrations"
m_migrations_path = Server.MapPath("../db/migrations/")
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Ensure the schema_migrations table exists
'-------------------------------------------------------------------------------------------------------------------
Public Sub EnsureSchemaMigrationsTable()
On Error Resume Next

' Try to query the table - if it doesn't exist, create it
Dim rs
Set rs = m_db.Query("SELECT TOP 1 version FROM " & m_schema_table, empty)

If Err.Number <> 0 Then
' Table doesn't exist, create it
Err.Clear
On Error GoTo 0

Dim createSQL
createSQL = "CREATE TABLE " & m_schema_table & " (" & _
"version VARCHAR(14) PRIMARY KEY, " & _
"applied_at DATETIME NOT NULL)"

m_db.Execute createSQL, empty
Else
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
End If

On Error GoTo 0
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Get all applied migration versions
'-------------------------------------------------------------------------------------------------------------------
Public Function GetAppliedMigrations()
EnsureSchemaMigrationsTable

Dim rs, versions, version
Set versions = Server.CreateObject("Scripting.Dictionary")

Set rs = m_db.Query("SELECT version FROM " & m_schema_table & " ORDER BY version", empty)

Do While Not rs.EOF
version = Trim(rs("version"))
versions.Add version, True
rs.MoveNext
Loop

rs.Close
Set rs = Nothing

Set GetAppliedMigrations = versions
End Function

'-------------------------------------------------------------------------------------------------------------------
' Get all available migration files
'-------------------------------------------------------------------------------------------------------------------
Public Function GetAvailableMigrations()
Dim fso, folder, files, file
Set fso = Server.CreateObject("Scripting.FileSystemObject")

If Not fso.FolderExists(m_migrations_path) Then
Set GetAvailableMigrations = Server.CreateObject("Scripting.Dictionary")
Exit Function
End If

Set folder = fso.GetFolder(m_migrations_path)
Set files = folder.Files

Dim migrations
Set migrations = Server.CreateObject("Scripting.Dictionary")

For Each file In files
If LCase(fso.GetExtensionName(file.Name)) = "asp" Then
Dim version
version = GetVersionFromFilename(file.Name)
If version <> "" Then
migrations.Add version, file.Name
End If
End If
Next

Set GetAvailableMigrations = migrations
End Function

'-------------------------------------------------------------------------------------------------------------------
' Get pending migrations (available but not applied)
'-------------------------------------------------------------------------------------------------------------------
Public Function GetPendingMigrations()
Dim applied, available, pending, version
Set applied = GetAppliedMigrations()
Set available = GetAvailableMigrations()
Set pending = Server.CreateObject("Scripting.Dictionary")

For Each version In available.Keys
If Not applied.Exists(version) Then
pending.Add version, available(version)
End If
Next

Set GetPendingMigrations = pending
End Function

'-------------------------------------------------------------------------------------------------------------------
' Extract version from migration filename
' Expected format: YYYYMMDDHHMMSS_description.asp
'-------------------------------------------------------------------------------------------------------------------
Private Function GetVersionFromFilename(filename)
Dim parts
parts = Split(filename, "_")

If UBound(parts) >= 0 Then
Dim version
version = parts(0)
' Validate it's a 14-digit timestamp
If Len(version) = 14 And IsNumeric(version) Then
GetVersionFromFilename = version
Exit Function
End If
End If

GetVersionFromFilename = ""
End Function

'-------------------------------------------------------------------------------------------------------------------
' Apply a migration (run the Up method)
'-------------------------------------------------------------------------------------------------------------------
Public Sub ApplyMigration(filename)
Dim version
version = GetVersionFromFilename(filename)

If version = "" Then
Err.Raise vbObjectError + 1, "Migrator", "Invalid migration filename format: " & filename
End If

' Check if already applied
Dim applied
Set applied = GetAppliedMigrations()
If applied.Exists(version) Then
Response.Write "Migration " & version & " already applied. Skipping." & vbCrLf
Exit Sub
End If

Response.Write "Applying migration: " & filename & "..." & vbCrLf

' Begin transaction
m_db.BeginTransaction

On Error Resume Next

' Execute the migration file
ExecuteMigrationFile filename, "Up"

If Err.Number <> 0 Then
Dim errMsg
errMsg = "Migration failed: " & Err.Description
m_db.RollbackTransaction
Err.Raise vbObjectError + 2, "Migrator", errMsg
End If

' Record the migration
m_db.Execute "INSERT INTO " & m_schema_table & " (version, applied_at) VALUES (?, ?)", _
Array(version, Now())

If Err.Number <> 0 Then
Dim recordErr
recordErr = "Failed to record migration: " & Err.Description
m_db.RollbackTransaction
Err.Raise vbObjectError + 3, "Migrator", recordErr
End If

' Commit transaction
m_db.CommitTransaction

On Error GoTo 0

Response.Write "Migration " & version & " applied successfully." & vbCrLf
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Rollback a migration (run the Down method)
'-------------------------------------------------------------------------------------------------------------------
Public Sub RollbackMigration(filename)
Dim version
version = GetVersionFromFilename(filename)

If version = "" Then
Err.Raise vbObjectError + 1, "Migrator", "Invalid migration filename format: " & filename
End If

' Check if applied
Dim applied
Set applied = GetAppliedMigrations()
If Not applied.Exists(version) Then
Response.Write "Migration " & version & " not applied. Skipping." & vbCrLf
Exit Sub
End If

Response.Write "Rolling back migration: " & filename & "..." & vbCrLf

' Begin transaction
m_db.BeginTransaction

On Error Resume Next

' Execute the migration file
ExecuteMigrationFile filename, "Down"

If Err.Number <> 0 Then
Dim errMsg
errMsg = "Rollback failed: " & Err.Description
m_db.RollbackTransaction
Err.Raise vbObjectError + 4, "Migrator", errMsg
End If

' Remove the migration record
m_db.Execute "DELETE FROM " & m_schema_table & " WHERE version = ?", version

If Err.Number <> 0 Then
Dim recordErr
recordErr = "Failed to remove migration record: " & Err.Description
m_db.RollbackTransaction
Err.Raise vbObjectError + 5, "Migrator", recordErr
End If

' Commit transaction
m_db.CommitTransaction

On Error GoTo 0

Response.Write "Migration " & version & " rolled back successfully." & vbCrLf
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Execute a migration file's Up or Down method
'-------------------------------------------------------------------------------------------------------------------
Private Sub ExecuteMigrationFile(filename, direction)
Dim migrationPath
migrationPath = m_migrations_path & filename

Dim fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")

If Not fso.FileExists(migrationPath) Then
Err.Raise vbObjectError + 6, "Migrator", "Migration file not found: " & migrationPath
End If

' Create a migration context that the file can use
Dim migration
Set migration = New MigrationContext_Class
Set migration.DB = m_db

' Include and execute the migration file
Server.Execute(migrationPath)

' Call the appropriate method (Up or Down)
If direction = "Up" Then
Execute "Call Migration_Up(migration)"
ElseIf direction = "Down" Then
Execute "Call Migration_Down(migration)"
End If
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Apply all pending migrations
'-------------------------------------------------------------------------------------------------------------------
Public Sub ApplyAllPending()
Dim pending, version, versions()
Set pending = GetPendingMigrations()

If pending.Count = 0 Then
Response.Write "No pending migrations." & vbCrLf
Exit Sub
End If

' Sort versions
ReDim versions(pending.Count - 1)
Dim i : i = 0
For Each version In pending.Keys
versions(i) = version
i = i + 1
Next

' Simple bubble sort for versions
Dim j, temp
For i = 0 To UBound(versions) - 1
For j = i + 1 To UBound(versions)
If CLng(versions(i)) > CLng(versions(j)) Then
temp = versions(i)
versions(i) = versions(j)
versions(j) = temp
End If
Next
Next

' Apply in order
For i = 0 To UBound(versions)
ApplyMigration pending(versions(i))
Next
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Rollback the last applied migration
'-------------------------------------------------------------------------------------------------------------------
Public Sub RollbackLast()
Dim applied, version, lastVersion
Set applied = GetAppliedMigrations()

If applied.Count = 0 Then
Response.Write "No migrations to rollback." & vbCrLf
Exit Sub
End If

' Find the last version
lastVersion = ""
For Each version In applied.Keys
If lastVersion = "" Or CLng(version) > CLng(lastVersion) Then
lastVersion = version
End If
Next

' Find the filename
Dim available
Set available = GetAvailableMigrations()

If available.Exists(lastVersion) Then
RollbackMigration available(lastVersion)
Else
Err.Raise vbObjectError + 7, "Migrator", "Migration file not found for version: " & lastVersion
End If
End Sub

End Class

'=======================================================================================================================
' MIGRATION CONTEXT
'=======================================================================================================================
' Provides helper methods for use within migration files
'
Class MigrationContext_Class
Public DB ' Reference to DAL

'-------------------------------------------------------------------------------------------------------------------
' Execute raw SQL
'-------------------------------------------------------------------------------------------------------------------
Public Sub ExecuteSQL(sql)
DB.Execute sql, empty
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Create a table
'-------------------------------------------------------------------------------------------------------------------
Public Sub CreateTable(tableName, columns)
Dim sql
sql = "CREATE TABLE " & tableName & " (" & columns & ")"
ExecuteSQL sql
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Drop a table
'-------------------------------------------------------------------------------------------------------------------
Public Sub DropTable(tableName)
ExecuteSQL "DROP TABLE " & tableName
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Add a column to a table
'-------------------------------------------------------------------------------------------------------------------
Public Sub AddColumn(tableName, columnName, columnType)
ExecuteSQL "ALTER TABLE " & tableName & " ADD COLUMN " & columnName & " " & columnType
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Drop a column from a table
'-------------------------------------------------------------------------------------------------------------------
Public Sub DropColumn(tableName, columnName)
ExecuteSQL "ALTER TABLE " & tableName & " DROP COLUMN " & columnName
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Create an index
'-------------------------------------------------------------------------------------------------------------------
Public Sub CreateIndex(indexName, tableName, columns)
ExecuteSQL "CREATE INDEX " & indexName & " ON " & tableName & " (" & columns & ")"
End Sub

'-------------------------------------------------------------------------------------------------------------------
' Drop an index
'-------------------------------------------------------------------------------------------------------------------
Public Sub DropIndex(indexName, tableName)
ExecuteSQL "DROP INDEX " & indexName & " ON " & tableName
End Sub
End Class

'=======================================================================================================================
' SINGLETON
'=======================================================================================================================
Dim Migrator__Singleton : Set Migrator__Singleton = Nothing

Function Migrator()
If Migrator__Singleton Is Nothing Then
Set Migrator__Singleton = New Migrator_Class
End If
Set Migrator = Migrator__Singleton
End Function
%>

+ 262
- 0
core/lib.Routes.asp 查看文件

@@ -0,0 +1,262 @@
<%
'=======================================================================================================================
' ROUTING HELPER
' Provides URL generation for RouteKit framework
'=======================================================================================================================
Class Route_Helper_Class
Private m_app_url
Private m_content_url
Private m_stylesheets_url
Private m_js_url
Private m_images_url
Private m_enable_cache_busting
Private m_cache_bust_param_name

Private Sub Class_Initialize()
' Auto-detect application URL from current request
Dim protocol, host, appPath
protocol = IIf(Request.ServerVariables("HTTPS") = "on", "https://", "http://")
host = Request.ServerVariables("HTTP_HOST")
appPath = Request.ServerVariables("APPL_MD_PATH")

' Extract virtual directory from IIS path
Dim vdir
vdir = ""
If InStr(appPath, "/LM/W3SVC/") > 0 Then
vdir = Mid(appPath, InStrRev(appPath, "/") + 1)
If vdir <> "ROOT" Then
vdir = "/" & vdir
Else
vdir = ""
End If
End If

m_app_url = protocol & host & vdir & "/"
m_content_url = m_app_url & "content/"
m_stylesheets_url = m_app_url & "css/"
m_js_url = m_app_url & "js/"
m_images_url = m_app_url & "images/"

' Load cache-busting configuration
Dim cacheBustSetting
cacheBustSetting = GetAppSetting("EnableCacheBusting")
m_enable_cache_busting = (cacheBustSetting = "true" Or cacheBustSetting = "True")

' Get cache-bust parameter name (default: "v")
m_cache_bust_param_name = GetAppSetting("CacheBustParamName")
If m_cache_bust_param_name = "nothing" Or Len(m_cache_bust_param_name) = 0 Then
m_cache_bust_param_name = "v"
End If
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Cache-busting token (timestamp-based for uniqueness)
'---------------------------------------------------------------------------------------------------------------------
Public Property Get NoCacheToken
NoCacheToken = CLng(Timer() * 100)
End Property

'---------------------------------------------------------------------------------------------------------------------
' Check if cache-busting is globally enabled
'---------------------------------------------------------------------------------------------------------------------
Public Property Get CacheBustingEnabled
CacheBustingEnabled = m_enable_cache_busting
End Property

'---------------------------------------------------------------------------------------------------------------------
' Get/Set cache-busting enabled (can override config at runtime)
'---------------------------------------------------------------------------------------------------------------------
Public Property Let CacheBustingEnabled(value)
m_enable_cache_busting = value
End Property

'---------------------------------------------------------------------------------------------------------------------
' URL Properties
'---------------------------------------------------------------------------------------------------------------------
Public Property Get AppURL
AppURL = m_app_url
End Property

Public Property Get ContentURL
ContentURL = m_content_url
End Property

Public Property Get StylesheetsURL
StylesheetsURL = m_stylesheets_url
End Property

Public Property Get JsURL
JsURL = m_js_url
End Property

Public Property Get ImagesURL
ImagesURL = m_images_url
End Property

'---------------------------------------------------------------------------------------------------------------------
' Generate clean URL for controller/action (RouteKit style)
'
' @param controller_name String Name of controller (without "Controller" suffix)
' @param action_name String Name of action method
' @param params_array KV Array Optional key/value pair array for query string
' @returns String Clean URL like "/controller/action?key=val"
'---------------------------------------------------------------------------------------------------------------------
Public Function UrlTo(controller_name, action_name, params_array)
Dim url, qs

' Build clean URL: /controller/action
url = m_app_url & LCase(controller_name) & "/" & LCase(action_name)

' Add query string parameters if provided
qs = TO_Querystring(params_array)
If Len(qs) > 0 Then
url = url & "?" & qs
End If

UrlTo = url
End Function

'---------------------------------------------------------------------------------------------------------------------
' Generate URL with route parameters (e.g., /users/show/123)
'
' @param controller_name String Name of controller
' @param action_name String Name of action method
' @param route_params Array Route parameters (e.g., Array(123) for ID)
' @param query_params KV Array Optional query string parameters
' @returns String URL with route params
'---------------------------------------------------------------------------------------------------------------------
Public Function UrlToWithParams(controller_name, action_name, route_params, query_params)
Dim url, qs, i

' Build base URL
url = m_app_url & LCase(controller_name) & "/" & LCase(action_name)

' Append route parameters
If IsArray(route_params) Then
For i = 0 To UBound(route_params)
url = url & "/" & Server.URLEncode(CStr(route_params(i)))
Next
ElseIf Not IsEmpty(route_params) Then
url = url & "/" & Server.URLEncode(CStr(route_params))
End If

' Add query string parameters if provided
qs = TO_Querystring(query_params)
If Len(qs) > 0 Then
url = url & "?" & qs
End If

UrlToWithParams = url
End Function

'---------------------------------------------------------------------------------------------------------------------
' Generate URL for static asset with cache-busting
'
' @param asset_path String Relative path to asset (e.g., "css/site.css")
' @param use_cache_bust Variant Boolean or Empty. If Empty, uses global setting. If True/False, overrides.
' @returns String Full URL to asset
'---------------------------------------------------------------------------------------------------------------------
Public Function AssetUrl(asset_path, use_cache_bust)
Dim url, shouldBust
url = m_app_url & asset_path

' Determine if we should cache-bust
If IsEmpty(use_cache_bust) Then
shouldBust = m_enable_cache_busting
Else
shouldBust = CBool(use_cache_bust)
End If

If shouldBust Then
url = AppendCacheBustParam(url)
End If

AssetUrl = url
End Function

'---------------------------------------------------------------------------------------------------------------------
' Generate URL for route with optional cache-busting
'
' @param controller_name String Name of controller
' @param action_name String Name of action
' @param params_array KV Array Optional query params
' @param use_cache_bust Variant Boolean or Empty. If Empty, uses global setting
' @returns String URL with optional cache-busting
'---------------------------------------------------------------------------------------------------------------------
Public Function UrlToWithCacheBust(controller_name, action_name, params_array, use_cache_bust)
Dim url
url = UrlTo(controller_name, action_name, params_array)

' Determine if we should cache-bust
Dim shouldBust
If IsEmpty(use_cache_bust) Then
shouldBust = m_enable_cache_busting
Else
shouldBust = CBool(use_cache_bust)
End If

If shouldBust Then
url = AppendCacheBustParam(url)
End If

UrlToWithCacheBust = url
End Function


'---------------------------------------------------------------------------------------------------------------------
' PRIVATE HELPER METHODS
'---------------------------------------------------------------------------------------------------------------------
Private Function TO_Querystring(the_array)
Dim result, idx
result = ""

If Not IsEmpty(the_array) And IsArray(the_array) Then
' Process key-value pairs (array with even number of elements)
For idx = LBound(the_array) To UBound(the_array) Step 2
If idx + 1 <= UBound(the_array) Then
result = result & GetParam(the_array, idx)
' Append & between parameters, but not on the last parameter
If Not (idx >= UBound(the_array) - 1) Then
result = result & "&"
End If
End If
Next
End If

TO_Querystring = result
End Function

Private Function GetParam(params_array, key_idx)
Dim key, val
key = Server.URLEncode(CStr(params_array(key_idx)))
val = Server.URLEncode(CStr(params_array(key_idx + 1)))
GetParam = key & "=" & val
End Function

Private Function AppendCacheBustParam(url)
Dim separator
' Determine if we need ? or &
If InStr(url, "?") > 0 Then
separator = "&"
Else
separator = "?"
End If
AppendCacheBustParam = url & separator & m_cache_bust_param_name & "=" & NoCacheToken
End Function
End Class


'---------------------------------------------------------------------------------------------------------------------
' Singleton accessor
'---------------------------------------------------------------------------------------------------------------------
Dim Route_Helper__Singleton
Set Route_Helper__Singleton = Nothing

Function Routes()
If Route_Helper__Singleton Is Nothing Then
Set Route_Helper__Singleton = New Route_Helper_Class
End If
Set Routes = Route_Helper__Singleton
End Function

%>

+ 73
- 0
core/lib.Strings.asp 查看文件

@@ -0,0 +1,73 @@
<%
'=======================================================================================================================
' StringBuilder Class
'=======================================================================================================================
Class StringBuilder_Class
dim m_array
dim m_array_size
dim m_cur_pos
Private Sub Class_Initialize
m_array = Array
m_array_size = 100
redim m_array(m_array_size)
m_cur_pos = -1
End Sub
Private Sub Extend
m_array_size = m_array_size + 100
redim preserve m_array(m_array_size)
End Sub
Public Sub Add(s)
m_cur_pos = m_cur_pos + 1
m_array(m_cur_pos) = s
if m_cur_pos = m_array_size then Extend
End Sub
Public Function [Get](delim)
'have to create a new array containing only the slots actually used, otherwise Join() happily adds delim
'for *every* slot even the unused ones...
dim new_array : new_array = Array()
redim new_array(m_cur_pos)
dim i
for i = 0 to m_cur_pos
new_array(i) = m_array(i)
next
[Get] = Join(new_array, delim)
End Function
Public Default Property Get TO_String
TO_String = Join(m_array, "")
End Property
End Class

Function StringBuilder()
set StringBuilder = new StringBuilder_Class
End Function


'=======================================================================================================================
' Misc
'=======================================================================================================================
Function Excerpt(text, length)
Excerpt = Left(text, length) & " ..."
End Function

Function IsBlank(text)
If IsObject(text) then
If text Is Nothing then
IsBlank = true
Else
IsBlank = false
End If
Else
If IsEmpty(text) or IsNull(text) or Len(text) = 0 then
IsBlank = true
Else
IsBlank = false
End If
End If
End Function

%>

+ 405
- 0
core/lib.Upload.asp 查看文件

@@ -0,0 +1,405 @@
<!--METADATA
TYPE="TypeLib"
NAME="Microsoft ActiveX Data Objects 2.5 Library"
UUID="{00000205-0000-0010-8000-00AA006D2EA4}"
VERSION="2.5"
-->


<%
' For examples, documentation, and your own free copy, go to:
' http://www.freeaspupload.net
' Note: You can copy and use this script for free and you can make changes
' to the code, but you cannot remove the above comment.

'Changes:
'Aug 2, 2005: Add support for checkboxes and other input elements with multiple values
'Jan 6, 2009: Lars added ASP_CHUNK_SIZE

const DEFAULT_ASP_CHUNK_SIZE = 200000

Class FreeASPUpload
Public UploadedFiles
Public FormElements

Private VarArrayBinRequest
Private StreamRequest
Private uploadedYet
Private internalChunkSize

Private Sub Class_Initialize()
Set UploadedFiles = Server.CreateObject("Scripting.Dictionary")
Set FormElements = Server.CreateObject("Scripting.Dictionary")
Set StreamRequest = Server.CreateObject("ADODB.Stream")
StreamRequest.Type = 2 ' adTypeText
StreamRequest.Open
uploadedYet = false
internalChunkSize = DEFAULT_ASP_CHUNK_SIZE
End Sub
Private Sub Class_Terminate()
If IsObject(UploadedFiles) Then
UploadedFiles.RemoveAll()
Set UploadedFiles = Nothing
End If
If IsObject(FormElements) Then
FormElements.RemoveAll()
Set FormElements = Nothing
End If
StreamRequest.Close
Set StreamRequest = Nothing
End Sub

Public Property Get Form(sIndex)
Form = ""
If FormElements.Exists(LCase(sIndex)) Then Form = FormElements.Item(LCase(sIndex))
End Property

Public Property Get Files()
Files = UploadedFiles.Items
End Property
Public Property Get Exists(sIndex)
Exists = false
If FormElements.Exists(LCase(sIndex)) Then Exists = true
End Property

Public Property Get FileExists(sIndex)
FileExists = false
if UploadedFiles.Exists(LCase(sIndex)) then FileExists = true
End Property

Public Property Get chunkSize()
chunkSize = internalChunkSize
End Property

Public Property Let chunkSize(sz)
internalChunkSize = sz
End Property

'Calls Upload to extract the data from the binary request and then saves the uploaded files
Public Sub Save(path)
Dim streamFile, fileItem

if Right(path, 1) <> "\" then path = path & "\"

if not uploadedYet then Upload

For Each fileItem In UploadedFiles.Items
Set streamFile = Server.CreateObject("ADODB.Stream")
streamFile.Type = 1
streamFile.Open
StreamRequest.Position=fileItem.Start
StreamRequest.CopyTo streamFile, fileItem.Length
streamFile.SaveToFile path & fileItem.FileName, 2
streamFile.close
Set streamFile = Nothing
fileItem.Path = path & fileItem.FileName
Next
End Sub
public sub SaveOne(path, num, byref outFileName, byref outLocalFileName)
Dim streamFile, fileItems, fileItem, fs

set fs = Server.CreateObject("Scripting.FileSystemObject")
if Right(path, 1) <> "\" then path = path & "\"

if not uploadedYet then Upload
if UploadedFiles.Count > 0 then
fileItems = UploadedFiles.Items
set fileItem = fileItems(num)
outFileName = fileItem.FileName
outLocalFileName = GetFileName(path, outFileName)
Set streamFile = Server.CreateObject("ADODB.Stream")
streamFile.Type = 1
streamFile.Open
StreamRequest.Position = fileItem.Start
StreamRequest.CopyTo streamFile, fileItem.Length
streamFile.SaveToFile path & outLocalFileName, 2
streamFile.close
Set streamFile = Nothing
fileItem.Path = path & filename
end if
end sub

Public Function SaveBinRequest(path) ' For debugging purposes
StreamRequest.SaveToFile path & "\debugStream.bin", 2
End Function

Public Sub DumpData() 'only works if files are plain text
Dim i, aKeys, f
response.write "Form Items:<br>"
aKeys = FormElements.Keys
For i = 0 To FormElements.Count -1 ' Iterate the array
response.write aKeys(i) & " = " & FormElements.Item(aKeys(i)) & "<BR>"
Next
response.write "Uploaded Files:<br>"
For Each f In UploadedFiles.Items
response.write "Name: " & f.FileName & "<br>"
response.write "Type: " & f.ContentType & "<br>"
response.write "Start: " & f.Start & "<br>"
response.write "Size: " & f.Length & "<br>"
Next
End Sub

Public Sub Upload()
Dim nCurPos, nDataBoundPos, nLastSepPos
Dim nPosFile, nPosBound
Dim sFieldName, osPathSep, auxStr
Dim readBytes, readLoop, tmpBinRequest
'RFC1867 Tokens
Dim vDataSep
Dim tNewLine, tDoubleQuotes, tTerm, tFilename, tName, tContentDisp, tContentType
tNewLine = String2Byte(Chr(13))
tDoubleQuotes = String2Byte(Chr(34))
tTerm = String2Byte("--")
tFilename = String2Byte("filename=""")
tName = String2Byte("name=""")
tContentDisp = String2Byte("Content-Disposition")
tContentType = String2Byte("Content-Type:")

uploadedYet = true

on error resume next
readBytes = internalChunkSize
VarArrayBinRequest = Request.BinaryRead(readBytes)
VarArrayBinRequest = midb(VarArrayBinRequest, 1, lenb(VarArrayBinRequest))
for readLoop = 0 to 300000
tmpBinRequest = Request.BinaryRead(readBytes)
if readBytes < 1 then exit for
VarArrayBinRequest = VarArrayBinRequest & midb(tmpBinRequest, 1, lenb(tmpBinRequest))
next
if Err.Number <> 0 then
response.write "<br><br><B>System reported this error:</B><p>"
response.write Err.Description & "<p>"
response.write "The most likely cause for this error is the incorrect setup of AspMaxRequestEntityAllowed in IIS MetaBase. Please see instructions in the <A HREF='http://www.freeaspupload.net/freeaspupload/requirements.asp'>requirements page of freeaspupload.net</A>.<p>"
Exit Sub
end if
on error goto 0 'reset error handling

nCurPos = FindToken(tNewLine,1) 'Note: nCurPos is 1-based (and so is InstrB, MidB, etc)

If nCurPos <= 1 Then Exit Sub
'vDataSep is a separator like -----------------------------21763138716045
vDataSep = MidB(VarArrayBinRequest, 1, nCurPos-1)

'Start of current separator
nDataBoundPos = 1

'Beginning of last line
nLastSepPos = FindToken(vDataSep & tTerm, 1)

Do Until nDataBoundPos = nLastSepPos
nCurPos = SkipToken(tContentDisp, nDataBoundPos)
nCurPos = SkipToken(tName, nCurPos)
sFieldName = ExtractField(tDoubleQuotes, nCurPos)

nPosFile = FindToken(tFilename, nCurPos)
nPosBound = FindToken(vDataSep, nCurPos)
If nPosFile <> 0 And nPosFile < nPosBound Then
Dim oUploadFile
Set oUploadFile = New UploadedFile
nCurPos = SkipToken(tFilename, nCurPos)
auxStr = ExtractField(tDoubleQuotes, nCurPos)
' We are interested only in the name of the file, not the whole path
' Path separator is \ in windows, / in UNIX
' While IE seems to put the whole pathname in the stream, Mozilla seem to
' only put the actual file name, so UNIX paths may be rare. But not impossible.
osPathSep = "\"
if InStr(auxStr, osPathSep) = 0 then osPathSep = "/"
oUploadFile.FileName = Right(auxStr, Len(auxStr)-InStrRev(auxStr, osPathSep))

if (Len(oUploadFile.FileName) > 0) then 'File field not left empty
nCurPos = SkipToken(tContentType, nCurPos)
auxStr = ExtractField(tNewLine, nCurPos)
' NN on UNIX puts things like this in the stream:
' ?? python py type=?? python application/x-python
oUploadFile.ContentType = Right(auxStr, Len(auxStr)-InStrRev(auxStr, " "))
nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line
oUploadFile.Start = nCurPos+1
oUploadFile.Length = FindToken(vDataSep, nCurPos) - 2 - nCurPos
If oUploadFile.Length > 0 Then UploadedFiles.Add LCase(sFieldName), oUploadFile
End If
Else
Dim nEndOfData
nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line
nEndOfData = FindToken(vDataSep, nCurPos) - 2
If Not FormElements.Exists(LCase(sFieldName)) Then
FormElements.Add LCase(sFieldName), Byte2String(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos))
else
FormElements.Item(LCase(sFieldName))= FormElements.Item(LCase(sFieldName)) & ", " & Byte2String(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos))
end if

End If

'Advance to next separator
nDataBoundPos = FindToken(vDataSep, nCurPos)
Loop
StreamRequest.WriteText(VarArrayBinRequest)
End Sub

Private Function SkipToken(sToken, nStart)
SkipToken = InstrB(nStart, VarArrayBinRequest, sToken)
If SkipToken = 0 then
Response.write "Error in parsing uploaded binary request. The most likely cause for this error is the incorrect setup of AspMaxRequestEntityAllowed in IIS MetaBase. Please see instructions in the <A HREF='http://www.freeaspupload.net/freeaspupload/requirements.asp'>requirements page of freeaspupload.net</A>.<p>"
Response.End
end if
SkipToken = SkipToken + LenB(sToken)
End Function

Private Function FindToken(sToken, nStart)
FindToken = InstrB(nStart, VarArrayBinRequest, sToken)
End Function

Private Function ExtractField(sToken, nStart)
Dim nEnd
nEnd = InstrB(nStart, VarArrayBinRequest, sToken)
If nEnd = 0 then
Response.write "Error in parsing uploaded binary request."
Response.End
end if
ExtractField = Byte2String(MidB(VarArrayBinRequest, nStart, nEnd-nStart))
End Function

'String to byte string conversion
Private Function String2Byte(sString)
Dim i
For i = 1 to Len(sString)
String2Byte = String2Byte & ChrB(AscB(Mid(sString,i,1)))
Next
End Function

'Byte string to string conversion
Private Function Byte2String(bsString)
Dim i
dim b1, b2, b3, b4
Byte2String =""
For i = 1 to LenB(bsString)
if AscB(MidB(bsString,i,1)) < 128 then
' One byte
Byte2String = Byte2String & ChrW(AscB(MidB(bsString,i,1)))
elseif AscB(MidB(bsString,i,1)) < 224 then
' Two bytes
b1 = AscB(MidB(bsString,i,1))
b2 = AscB(MidB(bsString,i+1,1))
Byte2String = Byte2String & ChrW((((b1 AND 28) / 4) * 256 + (b1 AND 3) * 64 + (b2 AND 63)))
i = i + 1
elseif AscB(MidB(bsString,i,1)) < 240 then
' Three bytes
b1 = AscB(MidB(bsString,i,1))
b2 = AscB(MidB(bsString,i+1,1))
b3 = AscB(MidB(bsString,i+2,1))
Byte2String = Byte2String & ChrW(((b1 AND 15) * 16 + (b2 AND 60)) * 256 + (b2 AND 3) * 64 + (b3 AND 63))
i = i + 2
else
' Four bytes
b1 = AscB(MidB(bsString,i,1))
b2 = AscB(MidB(bsString,i+1,1))
b3 = AscB(MidB(bsString,i+2,1))
b4 = AscB(MidB(bsString,i+3,1))
' Don't know how to handle this, I believe Microsoft doesn't support these characters so I replace them with a "^"
'Byte2String = Byte2String & ChrW(((b1 AND 3) * 64 + (b2 AND 63)) & "," & (((b1 AND 28) / 4) * 256 + (b1 AND 3) * 64 + (b2 AND 63)))
Byte2String = Byte2String & "^"
i = i + 3
end if
Next
End Function
End Class

Class UploadedFile
Public ContentType
Public Start
Public Length
Public Path
Private nameOfFile

' Need to remove characters that are valid in UNIX, but not in Windows
Public Property Let FileName(fN)
nameOfFile = fN
nameOfFile = SubstNoReg(nameOfFile, "\", "_")
nameOfFile = SubstNoReg(nameOfFile, "/", "_")
nameOfFile = SubstNoReg(nameOfFile, ":", "_")
nameOfFile = SubstNoReg(nameOfFile, "*", "_")
nameOfFile = SubstNoReg(nameOfFile, "?", "_")
nameOfFile = SubstNoReg(nameOfFile, """", "_")
nameOfFile = SubstNoReg(nameOfFile, "<", "_")
nameOfFile = SubstNoReg(nameOfFile, ">", "_")
nameOfFile = SubstNoReg(nameOfFile, "|", "_")
End Property

Public Property Get FileName()
FileName = nameOfFile
End Property

'Public Property Get FileN()ame
End Class


' Does not depend on RegEx, which is not available on older VBScript
' Is not recursive, which means it will not run out of stack space
Function SubstNoReg(initialStr, oldStr, newStr)
Dim currentPos, oldStrPos, skip
If IsNull(initialStr) Or Len(initialStr) = 0 Then
SubstNoReg = ""
ElseIf IsNull(oldStr) Or Len(oldStr) = 0 Then
SubstNoReg = initialStr
Else
If IsNull(newStr) Then newStr = ""
currentPos = 1
oldStrPos = 0
SubstNoReg = ""
skip = Len(oldStr)
Do While currentPos <= Len(initialStr)
oldStrPos = InStr(currentPos, initialStr, oldStr)
If oldStrPos = 0 Then
SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, Len(initialStr) - currentPos + 1)
currentPos = Len(initialStr) + 1
Else
SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, oldStrPos - currentPos) & newStr
currentPos = oldStrPos + skip
End If
Loop
End If
End Function

Function GetFileName(strSaveToPath, FileName)
'This function is used when saving a file to check there is not already a file with the same name so that you don't overwrite it.
'It adds numbers to the filename e.g. file.gif becomes file1.gif becomes file2.gif and so on.
'It keeps going until it returns a filename that does not exist.
'You could just create a filename from the ID field but that means writing the record - and it still might exist!
'N.B. Requires strSaveToPath variable to be available - and containing the path to save to
Dim Counter
Dim Flag
Dim strTempFileName
Dim FileExt
Dim NewFullPath
dim objFSO, p
Set objFSO = CreateObject("Scripting.FileSystemObject")
Counter = 0
p = instrrev(FileName, ".")
FileExt = mid(FileName, p+1)
strTempFileName = left(FileName, p-1)
NewFullPath = strSaveToPath & "\" & FileName
Flag = False

Do Until Flag = True
If objFSO.FileExists(NewFullPath) = False Then
Flag = True
GetFileName = Mid(NewFullPath, InstrRev(NewFullPath, "\") + 1)
Else
Counter = Counter + 1
NewFullPath = strSaveToPath & "\" & strTempFileName & Counter & "." & FileExt
End If
Loop
End Function
%>

+ 250
- 0
core/lib.Validations.asp 查看文件

@@ -0,0 +1,250 @@
<%
'=======================================================================================================================
' Validation Classes
'=======================================================================================================================

'-----------------------------------------------------------------------------------------------------------------------
' Exists Validation
'-----------------------------------------------------------------------------------------------------------------------
Class ExistsValidation_Class
Private m_instance
Private m_field_name
Private m_message
Private m_ok
Public Function Initialize(instance, field_name, message)
set m_instance = instance
m_field_name = field_name
m_message = message
m_ok = true
set Initialize = Me
End Function
Public Sub Check
If Len(eval("m_instance." & m_field_name)) = 0 then
m_ok = false
End If
End Sub
Public Property Get OK
OK = m_ok
End Property
Public Property Get Message
Message = m_message
End Property
End Class

Sub ValidateExists(instance, field_name, message)
if not IsObject(instance.Validator) then set instance.Validator = new Validator_Class
instance.Validator.AddValidation new ExistsValidation_Class.Initialize(instance, field_name, message)
End Sub


'-----------------------------------------------------------------------------------------------------------------------
' Minimum Length Validation
'-----------------------------------------------------------------------------------------------------------------------
Class MinLengthValidation_Class
Private m_instance
Private m_field_name
Private m_size
Private m_message
Private m_ok
Public Function Initialize(instance, field_name, size, message)
set m_instance = instance
m_field_name = field_name
m_size = size
m_message = message
m_ok = true
set Initialize = Me
End Function
Public Sub Check
If Len(eval("m_instance." & m_field_name)) < m_size then m_ok = false
End Sub
Public Property Get OK
OK = m_ok
End Property
Public Property Get Message
Message = m_message
End Property
End Class

Sub ValidateMinLength(instance, field_name, size, message)
if not IsObject(instance.Validator) then set instance.Validator = new Validator_Class
instance.Validator.AddValidation new MinLengthValidation_Class.Initialize(instance, field_name, size, message)
End Sub

'-----------------------------------------------------------------------------------------------------------------------
' Max Length Validation
'-----------------------------------------------------------------------------------------------------------------------
Class MaxLengthValidation_Class
Private m_instance
Private m_field_name
Private m_size
Private m_message
Private m_ok
Public Function Initialize(instance, field_name, size, message)
set m_instance = instance
m_field_name = field_name
m_size = size
m_message = message
m_ok = true
set Initialize = Me
End Function
Public Sub Check
If Len(eval("m_instance." & m_field_name)) > m_size then m_ok = false
End Sub
Public Property Get OK
OK = m_ok
End Property
Public Property Get Message
Message = m_message
End Property
End Class

Sub ValidateMaxLength(instance, field_name, size, message)
if not IsObject(instance.Validator) then set instance.Validator = new Validator_Class
instance.Validator.AddValidation new MaxLengthValidation_Class.Initialize(instance, field_name, size, message)
End Sub

'-----------------------------------------------------------------------------------------------------------------------
' Numeric Validation
'-----------------------------------------------------------------------------------------------------------------------
Class NumericValidation_Class
Private m_instance
Private m_field_name
Private m_message
Private m_ok
Public Function Initialize(instance, field_name, message)
set m_instance = instance
m_field_name = field_name
m_message = message
m_ok = true
set Initialize = Me
End Function
Public Sub Check
If Not IsNumeric(eval("m_instance." & m_field_name)) then m_ok = false
End Sub
Public Property Get OK
OK = m_ok
End Property
Public Property Get Message
Message = m_message
End Property
End Class

Sub ValidateNumeric(instance, field_name, message)
if not IsObject(instance.Validator) then set instance.Validator = new Validator_Class
instance.Validator.AddValidation new NumericValidation_Class.Initialize(instance, field_name, message)
End Sub


'-----------------------------------------------------------------------------------------------------------------------
' Regular Expression Pattern Validation
'-----------------------------------------------------------------------------------------------------------------------
Class PatternValidation_Class
Private m_instance
Private m_field_name
Private m_pattern
Private m_message
Private m_ok
Public Function Initialize(instance, field_name, pattern, message)
set m_instance = instance
m_field_name = field_name
m_pattern = pattern
m_message = message
m_ok = true
set Initialize = Me
End Function
Public Sub Check
dim re : set re = new RegExp
With re
.Pattern = m_pattern
.Global = true
.IgnoreCase = true
End With
dim matches : set matches = re.Execute(eval("m_instance." & m_field_name))
if matches.Count = 0 then
m_ok = false
end if
End Sub
Public Property Get OK
OK = m_ok
End Property
Public Property Get Message
Message = m_message
End Property
End Class

Sub ValidatePattern(instance, field_name, pattern, message)
if not IsObject(instance.Validator) then set instance.Validator = new Validator_Class
instance.Validator.AddValidation new PatternValidation_Class.Initialize(instance, field_name, pattern, message)
End Sub



'-----------------------------------------------------------------------------------------------------------------------
' Validator Class
' This class is not intended to be used directly. Models should use the Validate* subs instead.
'-----------------------------------------------------------------------------------------------------------------------
Class Validator_Class
Private m_validations
Private m_errors
Private Sub Class_Initialize
m_validations = Array()
redim m_validations(-1)
m_errors = Array()
redim m_errors(-1)
End Sub
Public Property Get Errors
Errors = m_errors
End Property
Public Sub AddValidation(validation)
dim n : n = ubound(m_validations) + 1
redim preserve m_validations(n)
set m_validations(n) = validation
End Sub
Public Sub Validate
dim n : n = ubound(m_validations)
dim i, V
for i = 0 to n
set V = m_validations(i)
V.Check
if not V.OK then
AddError V.Message
end if
next
End Sub
Public Property Get HasErrors
HasErrors = (ubound(m_errors) > -1)
End Property
'Public to allow other errors to be added by the controller for circumstances not accounted for by the validators
Public Sub AddError(msg)
redim preserve m_errors(ubound(m_errors) + 1)
m_errors(ubound(m_errors)) = msg
End Sub
End Class
%>

+ 45
- 0
core/lib.crypto.helper.asp 查看文件

@@ -0,0 +1,45 @@
<%

Function HashPassword(password)
Dim shell, command, execObj, outputLine, result

' Create Shell Object
Set shell = CreateObject("WScript.Shell")

' Construct PowerShell Command

command = "cmd /c powershell -ExecutionPolicy Bypass -NoLogo -NoProfile -File """ & Server.MapPath(".") & "..\Core\hash_sha256.ps1"" -password " & password
' Execute Command
Set execObj = shell.Exec(command)
' Read Output
Do While Not execObj.StdOut.AtEndOfStream
outputLine = Trim(execObj.StdOut.ReadAll())
If outputLine <> "" Then
result = outputLine ' Capture the hash
End If
Loop

' Cleanup
Set shell = Nothing
Set execObj = Nothing

' Return the hash or error message
If result = "" Or Left(result, 5) = "ERROR" Then
HashPassword = result ' "ERROR: Hash not generated"
Else
HashPassword = result
End If
End Function

Function CheckPassword(username, password)
Dim user,UsersRepository
Set UsersRepository = CreateRepository(conn, "Users", "UserId")
' Find User
Set User = UsersRepository.Find(Array("UserName", user), Empty)
If user Is Nothing Then Exit Function ' Implicitly returns False

' Compare Hashed Password
CheckPassword = (HashPassword(password) = user.PasswordHash)
End Function
%>

+ 115
- 0
core/lib.helpers.asp 查看文件

@@ -0,0 +1,115 @@
<%
'protocol = IIf(LCase(Request.ServerVariables("HTTPS")) = "1", "https", "http")
protocol = "https"
Dim timeZones
timeZones = Array( _
Array("America/New_York", "Eastern (New York)"), _
Array("America/Chicago", "Central (Chicago)"), _
Array("America/Denver", "Mountain (Denver)"), _
Array("America/Los_Angeles", "Pacific (Los Angeles)"), _
Array("Europe/London", "London (UK)") _
)

Function RequestBinary()
On Error Resume Next
Dim stream, rawData

If Request.TotalBytes = 0 Then
RequestBinary = ""
Exit Function
End If

Set stream = Server.CreateObject("ADODB.Stream")
stream.Type = 1 ' adTypeBinary
stream.Open
stream.Write Request.BinaryRead(Request.TotalBytes)

stream.Position = 0
stream.Type = 2 ' adTypeText
stream.Charset = "utf-8"
rawData = stream.ReadText

stream.Close
Set stream = Nothing

If Err.Number <> 0 Then
rawData = ""
Err.Clear
End If

On Error GoTo 0
RequestBinary = rawData
End Function

Function ArrayContains(arr, val)
Dim i
ArrayContains = False
If IsArray(arr) Then
For i = LBound(arr) To UBound(arr)
If arr(i) = val Then
ArrayContains = True
Exit Function
End If
Next
End If
End Function

Function RenderPOBOArrayAsJson(pobo)
Dim i, j, obj, propList, propName, json, propVal, line,poboArray
if IsLinkedList(pobo) Then
poboArray = pobo.TO_Array()
End If
json = "["

If IsEmpty(poboArray) Then
RenderPOBOArrayAsJson = "[]"
Exit Function
End If

For i = 0 To UBound(poboArray)
Set obj = poboArray(i)
propList = obj.Properties
line = "{"

For j = 0 To UBound(propList)
propName = propList(j)
' Dynamically get value using Execute
Execute "propVal = obj." & propName

Select Case VarType(propVal)
Case vbString
line = line & """" & propName & """:""" & JsonEscape(propVal) & """"
Case vbBoolean
line = line & """" & propName & """:" & LCase(CStr(propVal))
Case vbDate
line = line & """" & propName & """:""" & Replace(CStr(propVal), """", "") & """"
Case vbNull
line = line & """" & propName & """:null"
Case Else
line = line & """" & propName & """:" & CStr(propVal)
End Select

If j < UBound(propList) Then
line = line & ","
End If
Next

line = line & "}"
If i < UBound(poboArray) Then line = line & ","
json = json & line
Next

json = json & "]"
RenderPOBOArrayAsJson = json
End Function

Function JsonEscape(str)
str = Replace(str, "\", "\\")
str = Replace(str, """", "\""")
str = Replace(str, vbCrLf, "\n")
str = Replace(str, vbLf, "\n")
str = Replace(str, vbCr, "\n")
str = Replace(str, Chr(9), "\t")
JsonEscape = str
End Function
%>

+ 284
- 0
core/lib.json.asp 查看文件

@@ -0,0 +1,284 @@
<%
'January 2021 - Version 1.1 by Gerrit van Kuipers
Class aspJSON
Public data
Private p_JSONstring
Private aj_in_string, aj_in_escape, aj_i_tmp, aj_char_tmp, aj_s_tmp, aj_line_tmp, aj_line, aj_lines, aj_currentlevel, aj_currentkey, aj_currentvalue, aj_newlabel, aj_XmlHttp, aj_RegExp, aj_colonfound

Private Sub Class_Initialize()
Set data = Collection()

Set aj_RegExp = New regexp
aj_RegExp.Pattern = "\s{0,}(\S{1}[\s,\S]*\S{1})\s{0,}"
aj_RegExp.Global = False
aj_RegExp.IgnoreCase = True
aj_RegExp.Multiline = True
End Sub

Private Sub Class_Terminate()
Set data = Nothing
Set aj_RegExp = Nothing
End Sub

Public Sub loadJSON(inputsource)
inputsource = aj_MultilineTrim(inputsource)
If Len(inputsource) = 0 Then Err.Raise 1, "loadJSON Error", "No data to load."
Select Case Left(inputsource, 1)
Case "{", "["
Case Else
Set aj_XmlHttp = Server.CreateObject("Msxml2.ServerXMLHTTP")
aj_XmlHttp.open "POST", inputsource, False
aj_XmlHttp.setRequestHeader "Content-Type", "text/json"
aj_XmlHttp.setRequestHeader "CharSet", "UTF-8"
aj_XmlHttp.Send
inputsource = aj_XmlHttp.responseText
Set aj_XmlHttp = Nothing
End Select

p_JSONstring = CleanUpJSONstring(inputsource)
aj_lines = Split(p_JSONstring, Chr(13) & Chr(10))

Dim level(99)
aj_currentlevel = 1
Set level(aj_currentlevel) = data
For Each aj_line In aj_lines
aj_currentkey = ""
aj_currentvalue = ""
If Instr(aj_line, ":") > 0 Then
aj_in_string = False
aj_in_escape = False
aj_colonfound = False
For aj_i_tmp = 1 To Len(aj_line)
If aj_in_escape Then
aj_in_escape = False
Else
Select Case Mid(aj_line, aj_i_tmp, 1)
Case """"
aj_in_string = Not aj_in_string
Case ":"
If Not aj_in_escape And Not aj_in_string Then
aj_currentkey = Left(aj_line, aj_i_tmp - 1)
aj_currentvalue = Mid(aj_line, aj_i_tmp + 1)
aj_colonfound = True
Exit For
End If
Case "\"
aj_in_escape = True
End Select
End If
Next
if aj_colonfound then
aj_currentkey = aj_Strip(aj_JSONDecode(aj_currentkey), """")
If Not level(aj_currentlevel).exists(aj_currentkey) Then level(aj_currentlevel).Add aj_currentkey, ""
end if
End If
If right(aj_line,1) = "{" Or right(aj_line,1) = "[" Then
If Len(aj_currentkey) = 0 Then aj_currentkey = level(aj_currentlevel).Count
Set level(aj_currentlevel).Item(aj_currentkey) = Collection()
Set level(aj_currentlevel + 1) = level(aj_currentlevel).Item(aj_currentkey)
aj_currentlevel = aj_currentlevel + 1
aj_currentkey = ""
ElseIf right(aj_line,1) = "}" Or right(aj_line,1) = "]" or right(aj_line,2) = "}," Or right(aj_line,2) = "]," Then
aj_currentlevel = aj_currentlevel - 1
ElseIf Len(Trim(aj_line)) > 0 Then
If Len(aj_currentvalue) = 0 Then aj_currentvalue = aj_line
aj_currentvalue = getJSONValue(aj_currentvalue)

If Len(aj_currentkey) = 0 Then aj_currentkey = level(aj_currentlevel).Count
level(aj_currentlevel).Item(aj_currentkey) = aj_currentvalue
End If
Next
End Sub

Public Function Collection()
Set Collection = Server.CreateObject("Scripting.Dictionary")
End Function

Public Function AddToCollection(dictobj)
If TypeName(dictobj) <> "Dictionary" Then Err.Raise 1, "AddToCollection Error", "Not a collection."
aj_newlabel = dictobj.Count
dictobj.Add aj_newlabel, Collection()
Set AddToCollection = dictobj.item(aj_newlabel)
end function

Private Function CleanUpJSONstring(aj_originalstring)
aj_originalstring = Replace(aj_originalstring, Chr(13) & Chr(10), "")
aj_originalstring = Mid(aj_originalstring, 2, Len(aj_originalstring) - 2)
aj_in_string = False : aj_in_escape = False : aj_s_tmp = ""
For aj_i_tmp = 1 To Len(aj_originalstring)
aj_char_tmp = Mid(aj_originalstring, aj_i_tmp, 1)
If aj_in_escape Then
aj_in_escape = False
aj_s_tmp = aj_s_tmp & aj_char_tmp
Else
Select Case aj_char_tmp
Case "\" : aj_s_tmp = aj_s_tmp & aj_char_tmp : aj_in_escape = True
Case """" : aj_s_tmp = aj_s_tmp & aj_char_tmp : aj_in_string = Not aj_in_string
Case "{", "["
aj_s_tmp = aj_s_tmp & aj_char_tmp & aj_InlineIf(aj_in_string, "", Chr(13) & Chr(10))
Case "}", "]"
aj_s_tmp = aj_s_tmp & aj_InlineIf(aj_in_string, "", Chr(13) & Chr(10)) & aj_char_tmp
Case "," : aj_s_tmp = aj_s_tmp & aj_char_tmp & aj_InlineIf(aj_in_string, "", Chr(13) & Chr(10))
Case Else : aj_s_tmp = aj_s_tmp & aj_char_tmp
End Select
End If
Next

CleanUpJSONstring = ""
aj_s_tmp = Split(aj_s_tmp, Chr(13) & Chr(10))
For Each aj_line_tmp In aj_s_tmp
aj_line_tmp = Replace(Replace(aj_line_tmp, Chr(10), ""), Chr(13), "")
CleanUpJSONstring = CleanUpJSONstring & aj_Trim(aj_line_tmp) & Chr(13) & Chr(10)
Next
End Function

Private Function getJSONValue(ByVal val)
val = Trim(val)
If Left(val,1) = ":" Then val = Mid(val, 2)
If Right(val,1) = "," Then val = Left(val, Len(val) - 1)
val = Trim(val)

Select Case val
Case "true" : getJSONValue = True
Case "false" : getJSONValue = False
Case "null" : getJSONValue = Null
Case Else
If (Instr(val, """") = 0) Then
If IsNumeric(val) Then
getJSONValue = aj_ReadNumericValue(val)
Else
getJSONValue = val
End If
Else
If Left(val,1) = """" Then val = Mid(val, 2)
If Right(val,1) = """" Then val = Left(val, Len(val) - 1)
getJSONValue = aj_JSONDecode(Trim(val))
End If
End Select
End Function

Private JSONoutput_level
Public Function JSONoutput()
Dim wrap_dicttype, aj_label
JSONoutput_level = 1
wrap_dicttype = "[]"
For Each aj_label In data
If Not aj_IsInt(aj_label) Then wrap_dicttype = "{}"
Next
JSONoutput = Left(wrap_dicttype, 1) & Chr(13) & Chr(10) & GetDict(data) & Right(wrap_dicttype, 1)
End Function

Private Function GetDict(objDict)
Dim aj_item, aj_keyvals, aj_label, aj_dicttype
For Each aj_item In objDict
Select Case TypeName(objDict.Item(aj_item))
Case "Dictionary"
GetDict = GetDict & Space(JSONoutput_level * 4)
aj_dicttype = "[]"
For Each aj_label In objDict.Item(aj_item).Keys
If Not aj_IsInt(aj_label) Then aj_dicttype = "{}"
Next
If aj_IsInt(aj_item) Then
GetDict = GetDict & (Left(aj_dicttype,1) & Chr(13) & Chr(10))
Else
GetDict = GetDict & ("""" & aj_JSONEncode(aj_item) & """" & ": " & Left(aj_dicttype,1) & Chr(13) & Chr(10))
End If
JSONoutput_level = JSONoutput_level + 1
aj_keyvals = objDict.Keys
GetDict = GetDict & (GetSubDict(objDict.Item(aj_item)) & Space(JSONoutput_level * 4) & Right(aj_dicttype,1) & aj_InlineIf(aj_item = aj_keyvals(objDict.Count - 1),"" , ",") & Chr(13) & Chr(10))
Case Else
aj_keyvals = objDict.Keys
GetDict = GetDict & (Space(JSONoutput_level * 4) & aj_InlineIf(aj_IsInt(aj_item), "", """" & aj_JSONEncode(aj_item) & """: ") & WriteValue(objDict.Item(aj_item)) & aj_InlineIf(aj_item = aj_keyvals(objDict.Count - 1),"" , ",") & Chr(13) & Chr(10))
End Select
Next
End Function

Private Function aj_IsInt(val)
aj_IsInt = (TypeName(val) = "Integer" Or TypeName(val) = "Long")
End Function

Private Function GetSubDict(objSubDict)
GetSubDict = GetDict(objSubDict)
JSONoutput_level= JSONoutput_level -1
End Function

Private Function WriteValue(ByVal val)
Select Case TypeName(val)
Case "Double", "Integer", "Long": WriteValue = replace(val, ",", ".")
Case "Null" : WriteValue = "null"
Case "Boolean" : WriteValue = aj_InlineIf(val, "true", "false")
Case Else : WriteValue = """" & aj_JSONEncode(val) & """"
End Select
End Function

Private Function aj_JSONEncode(ByVal val)
val = Replace(val, "\", "\\")
val = Replace(val, """", "\""")
'val = Replace(val, "/", "\/")
val = Replace(val, Chr(8), "\b")
val = Replace(val, Chr(12), "\f")
val = Replace(val, Chr(10), "\n")
val = Replace(val, Chr(13), "\r")
val = Replace(val, Chr(9), "\t")
aj_JSONEncode = Trim(val)
End Function

Private Function aj_JSONDecode(ByVal val)
val = Replace(val, "\""", """")
val = Replace(val, "\\", "\")
val = Replace(val, "\/", "/")
val = Replace(val, "\b", Chr(8))
val = Replace(val, "\f", Chr(12))
val = Replace(val, "\n", Chr(10))
val = Replace(val, "\r", Chr(13))
val = Replace(val, "\t", Chr(9))
aj_JSONDecode = Trim(val)
End Function

Private Function aj_InlineIf(condition, returntrue, returnfalse)
If condition Then aj_InlineIf = returntrue Else aj_InlineIf = returnfalse
End Function

Private Function aj_Strip(ByVal val, stripper)
If Left(val, 1) = stripper Then val = Mid(val, 2)
If Right(val, 1) = stripper Then val = Left(val, Len(val) - 1)
aj_Strip = val
End Function

Private Function aj_MultilineTrim(TextData)
aj_MultilineTrim = aj_RegExp.Replace(TextData, "$1")
End Function

Private Function aj_Trim(val)
aj_Trim = Trim(val)
Do While Left(aj_Trim, 1) = Chr(9) : aj_Trim = Mid(aj_Trim, 2) : Loop
Do While Right(aj_Trim, 1) = Chr(9) : aj_Trim = Left(aj_Trim, Len(aj_Trim) - 1) : Loop
aj_Trim = Trim(aj_Trim)
End Function

Private Function aj_ReadNumericValue(ByVal val)
If Instr(val, ".") > 0 Then
numdecimals = Len(val) - Instr(val, ".")
val = Clng(Replace(val, ".", ""))
val = val / (10 ^ numdecimals)
aj_ReadNumericValue = val
Else
aj_ReadNumericValue = Clng(val)
End If
End Function
End Class

dim json_Class__Singleton
Function json()
if IsEmpty(json_Class__Singleton) then
set json_Class__Singleton = new aspJSON
end if
set json = json_Class__Singleton
End Function



%>

+ 166
- 0
core/mvc.asp 查看文件

@@ -0,0 +1,166 @@
<!--#include file="../app/Controllers/autoload_controllers.asp" -->
<%
' Set cache expiration from configuration
Dim cacheYear : cacheYear = GetAppSetting("CacheExpirationYear")
If cacheYear = "nothing" Then cacheYear = "2030"
Response.ExpiresAbsolute = "01/01/" & cacheYear
Response.AddHeader "pragma", "no-cache"
Response.AddHeader "cache-control", "private, no-cache, must-revalidate"
'=======================================================================================================================
' MVC Dispatcher
'=======================================================================================================================
Class MVC_Dispatcher_Class
dim CurrentController

Public Property Get ControllerName
ControllerName = CurrentController
end Property

'---------------------------------------------------------------------------------------------------------------------
' Convenience method to resolve route and dispatch in one call
' method: HTTP method (GET, POST, etc.)
' path: Request path (already cleaned of query params)
'---------------------------------------------------------------------------------------------------------------------
Public Sub DispatchRequest(method, path)
Dim routeArray
routeArray = router.Resolve(method, path)
Dispatch routeArray
End Sub

'---------------------------------------------------------------------------------------------------------------------
' Main dispatch method - executes a resolved route
' RouteArray: Array(controller, action, params) from router.Resolve()
'---------------------------------------------------------------------------------------------------------------------
Public Sub Dispatch(RouteArray)
On Error Resume Next
Dim controllerName, actionName, hasParams, paramsArray
controllerName = RouteArray(0)
actionName = RouteArray(1)

' Security: Validate controller and action names
If Not ControllerRegistry.IsValidControllerFormat(controllerName) Then
Response.Write "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; border-radius:4px;'>"
Response.Write "<strong>Security Error:</strong> Invalid controller name format."
Response.Write "</div>"
Exit Sub
End If

If Not ControllerRegistry.IsValidActionFormat(actionName) Then
Response.Write "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; border-radius:4px;'>"
Response.Write "<strong>Security Error:</strong> Invalid action name format."
Response.Write "</div>"
Exit Sub
End If

' Security: Check controller whitelist
If Not ControllerRegistry.IsValidController(controllerName) Then
Response.Write "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; border-radius:4px;'>"
Response.Write "<strong>Security Error:</strong> Controller '" & Server.HTMLEncode(controllerName) & "' is not registered."
Response.Write "</div>"
Exit Sub
End If

' Initialize current controller
Dim controllerAssignment : controllerAssignment = "Set CurrentController = " & controllerName & "()"
Execute controllerAssignment

' Check if layout should be used
hasParams = (UBound(RouteArray) >= 2)
If eval(controllerName & ".useLayout") Then
%> <!-- #include file="../app/views/Shared/Header.asp" --> <%
End If

' Prepare parameters
If hasParams Then
paramsArray = SurroundStringInArray(RouteArray(2))
Else
paramsArray = Empty
End If

' Execute controller action
ExecuteControllerAction controllerName, actionName, paramsArray

' Include footer if layout is used
If eval(controllerName & ".useLayout") Then
%> <!-- #include file="../app/views/Shared/Footer.asp" --> <%
End If
On Error GoTo 0
End Sub

' Helper method to execute controller actions (eliminates code duplication)
Private Sub ExecuteControllerAction(controllerName, actionName, paramsArray)
On Error Resume Next
Dim callString

' Build the call string based on whether we have parameters
If Not IsEmpty(paramsArray) And IsArray(paramsArray) And UBound(paramsArray) >= 0 Then
callString = "Call " & controllerName & "." & actionName & "(" & Join(paramsArray, ",") & ")"
Else
callString = "Call " & controllerName & "." & actionName & "()"
End If

' Execute the action
Execute callString

' Handle errors
If Err.Number <> 0 Then
HandleDispatchError actionName, Err.Description, Err.Number
Err.Clear
End If
On Error GoTo 0
End Sub

' Centralized error handling for dispatch errors
Private Sub HandleDispatchError(actionName, errorDesc, errorNum)
Dim isDevelopment
isDevelopment = (LCase(GetAppSetting("Environment")) = "development")

If isDevelopment Then
Response.Write "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; border-radius:4px;'>"
Response.Write "<strong>Controller Action Error</strong><br>"
Response.Write "Action: <code>" & Server.HTMLEncode(actionName) & "</code><br>"
Response.Write "Error: " & Server.HTMLEncode(errorDesc) & "<br>"
Response.Write "Error Number: " & errorNum
Response.Write "</div>"
Else
Response.Write "<div style='padding:15px; margin:10px; border:2px solid #dc3545; background:#f8d7da; color:#721c24; border-radius:4px;'>"
Response.Write "<strong>An error occurred</strong><br>"
Response.Write "Please contact the system administrator if the problem persists."
Response.Write "</div>"
End If
End Sub
Public Sub RequirePost
If Request.Form.Count = 0 Then MVC.RedirectToExt "NotValid","",empty:End If

End Sub

' Shortcut for RedirectToActionExt that does not require passing a parameters argument.
Public Sub RedirectToAction(ByVal action_name)
RedirectToActionExt action_name, empty
End Sub

Public Sub RedirectTo(controller_name, action_name)
RedirectToExt controller_name, action_name, empty
End Sub
' Redirects the browser to the specified action on the specified controller with the specified querystring parameters.
' params is a KVArray of querystring parameters.
Public Sub RedirectToExt(controller_name, action_name, params)
Response.Redirect Routes.UrlTo(controller_name, action_name, params)
End Sub

Public Sub RedirectToActionExt(ByVal action_name, ByVal params)
RedirectToExt ControllerName, action_name, params
End Sub

End Class
dim MVC_Dispatcher_Class__Singleton
Function MVC()
if IsEmpty(MVC_Dispatcher_Class__Singleton) then
set MVC_Dispatcher_Class__Singleton = new MVC_Dispatcher_Class
end if
set MVC = MVC_Dispatcher_Class__Singleton
End Function
%>

+ 147
- 0
core/router.wsc 查看文件

@@ -0,0 +1,147 @@
<?xml version="1.0"?>
<!-- RouterComponent.wsc -->
<component>

<!-- COM registration -->
<registration
description = "Classic ASP Router Component"
progid = "App.Router"
version = "1.0"
classid = "{A1FC6EA8-519E-4E34-AC08-77788E3E5E44}" />

<!-- Public interface -->
<public>
<method name="AddRoute"/>
<method name="Resolve"/>
</public>
<!-- Give the component ASP intrinsic objects (Request, Response, Server …) -->
<implements type="ASP"/>
<!-- Implementation -->
<script language="VBScript">
<![CDATA[
Option Explicit

'------------------------------------------------------------
' Private state
'------------------------------------------------------------
Dim routes : Set routes = CreateObject("Scripting.Dictionary")

'------------------------------------------------------------
' METHOD AddRoute(method, path, controller, action)
'------------------------------------------------------------
Public Sub AddRoute(method, path, controller, action)
' Input validation
If IsEmpty(method) Or Len(Trim(method)) = 0 Then
Err.Raise 5, "Router.AddRoute", "HTTP method parameter is required and cannot be empty"
End If

If IsEmpty(path) Then
Err.Raise 5, "Router.AddRoute", "Path parameter is required"
End If

If IsEmpty(controller) Or Len(Trim(controller)) = 0 Then
Err.Raise 5, "Router.AddRoute", "Controller parameter is required and cannot be empty"
End If

If IsEmpty(action) Or Len(Trim(action)) = 0 Then
Err.Raise 5, "Router.AddRoute", "Action parameter is required and cannot be empty"
End If

' Validate HTTP method (allow common methods)
Dim validMethods, methodUpper, i, isValidMethod
validMethods = Array("GET", "POST", "PUT", "DELETE", "PATCH", "HEAD", "OPTIONS")
methodUpper = UCase(Trim(method))
isValidMethod = False

For i = 0 To UBound(validMethods)
If validMethods(i) = methodUpper Then
isValidMethod = True
Exit For
End If
Next

If Not isValidMethod Then
Err.Raise 5, "Router.AddRoute", "Invalid HTTP method: " & method & ". Allowed: GET, POST, PUT, DELETE, PATCH, HEAD, OPTIONS"
End If

Dim routeKey
routeKey = methodUpper & ":" & LCase(Trim(path))

If Not routes.Exists(routeKey) Then
routes.Add routeKey, Array(Trim(controller), Trim(action))
End If
End Sub

'------------------------------------------------------------
' METHOD Resolve(method, path) -> Array(controller, action, params())
'------------------------------------------------------------
Public Function Resolve(method, path)
Dim routeKey, routeValue, values
routeKey = UCase(method) & ":" & LCase(path)

' Always return a params array (empty by default)
Dim emptyParams() : ReDim emptyParams(-1)

' Exact match first
If routes.Exists(routeKey) Then
routeValue = routes(routeKey)
Resolve = Array(routeValue(0), routeValue(1), emptyParams)
Exit Function
End If

' Dynamic routes (e.g. /users/:id)
Dim r, routeMethod, routePattern
For Each r In routes.Keys
routeMethod = Split(r, ":")(0)
routePattern = Mid(r, Len(routeMethod) + 2) ' strip "METHOD:"
If UCase(routeMethod) = UCase(method) Then
If IsMatch(path, routePattern, values) Then
routeValue = routes(r)
Resolve = Array(routeValue(0), routeValue(1), values)
Exit Function
End If
End If
Next

' 404 fallback
Resolve = Array("ErrorController", "NotFound", emptyParams)
End Function

'------------------------------------------------------------
' INTERNAL IsMatch(requestPath, routePattern, values())
' Returns True/False and fills values() with parameters
'------------------------------------------------------------
Private Function IsMatch(requestPath, routePattern, values)
Dim reqParts, routeParts, i, paramCount
reqParts = Split(requestPath, "/")
routeParts = Split(routePattern, "/")

If UBound(reqParts) <> UBound(routeParts) Then
IsMatch = False : Exit Function
End If

paramCount = 0 : ReDim values(-1)

For i = 0 To UBound(reqParts)
If Left(routeParts(i), 1) = ":" Then
ReDim Preserve values(paramCount)
values(paramCount) = reqParts(i)
paramCount = paramCount + 1
ElseIf LCase(routeParts(i)) <> LCase(reqParts(i)) Then
IsMatch = False : Exit Function
End If
Next

If paramCount = 0 Then ReDim values(-1)
IsMatch = True
End Function

'------------------------------------------------------------
' Optional lifecycle hooks
'------------------------------------------------------------
Private Sub Class_Terminate()
Set routes = Nothing
End Sub
]]>
</script>
</component>

二进制
db/webdata.accdb 查看文件


+ 13
- 0
public/Default.asp 查看文件

@@ -0,0 +1,13 @@
<!--#include file="..\core\autoload_core.asp" -->

<%
' Define application routes
router.AddRoute "GET", "/home", "homeController", "Index"
router.AddRoute "GET", "/", "homeController", "Index"
router.AddRoute "GET", "", "homeController", "Index"
router.AddRoute "GET", "/404", "ErrorController", "NotFound"

' Dispatch the request (resolves route and executes controller action)
MVC.DispatchRequest Request.ServerVariables("REQUEST_METHOD"), _
TrimQueryParams(Request.ServerVariables("HTTP_X_ORIGINAL_URL"))
%>

+ 70
- 0
public/web.config 查看文件

@@ -0,0 +1,70 @@
<?xml version="1.0" encoding="UTF-8"?>
<configuration>

<appSettings>
<!--
Access connection string.
IMPORTANT: Change Data Source to the real physical path
to your webdata.accdb file.
-->
<add key="ConnectionString"
value="Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\YourApp\db\webdata.accdb;Persist Security Info=False;" />

<!-- Environment flag (Development / Staging / Production) -->
<add key="Environment" value="Development" />

<!-- Flash message display duration in milliseconds -->
<add key="FlashMessageTimeout" value="3000" />

<!-- 404 error page redirect countdown in seconds -->
<add key="Error404RedirectSeconds" value="5" />

<!-- Cache expiration year for static content -->
<add key="CacheExpirationYear" value="2030" />

<!-- Maximum characters to display in table cells before truncating -->
<add key="TableCellMaxLength" value="90" />

<!-- Character threshold for textarea vs input field in forms -->
<add key="FormTextareaThreshold" value="100" />

<!-- Enable error logging to file (true/false) -->
<add key="EnableErrorLogging" value="false" />

<!-- Error log file path (if EnableErrorLogging is true) -->
<add key="ErrorLogPath" value="C:\YourApp\logs\errors.log" />

<!-- Enable cache-busting for URLs and assets (true/false) -->
<add key="EnableCacheBusting" value="false" />

<!-- Cache-bust parameter name (default: "v") -->
<add key="CacheBustParamName" value="v" />
</appSettings>

<system.webServer>
<!-- Default document for the site root -->
<defaultDocument>
<files>
<clear />
<add value="Default.asp" />
</files>
</defaultDocument>

<!-- URL Rewrite: send everything through Default.asp except static assets -->
<rewrite>
<rules>
<rule name="Rewrite to Default.asp" stopProcessing="true">
<match url="^(?!Default\.asp$|css/|js/|images/|aspunit/|favicon\.ico$).*$" />

<conditions>
<add input="{REQUEST_FILENAME}" matchType="IsFile" negate="true" />
<add input="{REQUEST_FILENAME}" matchType="IsDirectory" negate="true" />
</conditions>

<action type="Rewrite" url="/Default.asp" />
</rule>
</rules>
</rewrite>
</system.webServer>

</configuration>

+ 637
- 0
scripts/GenerateRepo.vbs 查看文件

@@ -0,0 +1,637 @@
'==============================================================
' GeneratePOBOAndRepository.vbs
'
' Usage:
' cscript //nologo GeneratePOBOAndRepository.vbs /table:Orders /pk:OrderID [/cs:MyConnString] [/config:C:\path\web.config]
'
' Reads connection string from web.config <appSettings>,
' discovers [table] schema, and generates:
' � POBO_<Table>.asp (Classic ASP class with typed Property Lets)
' � <Table>Repository.asp (parameterized CRUD + paging + search)
'
' Safe for Access or SQL Server connection strings.
'==============================================================

Option Explicit

'---------------- Args & paths ----------------
Dim fso, args, i, arg, parts
Dim tableName, primaryKey, csKey, configPath, thisFolder

Set fso = CreateObject("Scripting.FileSystemObject")
Set args = WScript.Arguments

csKey = "ConnectionString"
thisFolder = fso.GetParentFolderName(WScript.ScriptFullName)
configPath = fso.GetParentFolderName(fso.GetParentFolderName(WScript.ScriptFullName)) & "\public\web.config"

For i = 0 To args.Count - 1
arg = args(i)
If InStr(arg, ":") > 0 Then
parts = Split(arg, ":", 2)
Select Case LCase(Replace(parts(0), "/", ""))
Case "table": tableName = parts(1)
Case "pk": primaryKey = parts(1)
Case "cs": csKey = parts(1)
Case "config": configPath = parts(1)
End Select
End If
Next

If Len(tableName) = 0 Or Len(primaryKey) = 0 Then
WScript.Echo "Usage: cscript //nologo GeneratePOBOAndRepository.vbs /table:<TableName> /pk:<PrimaryKey> [/cs:<ConnStringKey>] [/config:<PathToWebConfig>]"
WScript.Quit 1
End If

' Validate table name format (alphanumeric, underscore only - prevent SQL injection)
If Not IsValidIdentifier(tableName) Then
WScript.Echo "Error: Invalid table name format. Only letters, numbers, and underscores are allowed."
WScript.Quit 1
End If

' Validate primary key format
If Not IsValidIdentifier(primaryKey) Then
WScript.Echo "Error: Invalid primary key format. Only letters, numbers, and underscores are allowed."
WScript.Quit 1
End If

'---------------- Config & connection ----------------
Dim connStr
connStr = GetAppSetting(csKey, configPath)
If connStr = "nothing" Then
WScript.Echo "Error: Key '" & csKey & "' not found in " & configPath
WScript.Quit 1
End If

Dim conn
Set conn = CreateObject("ADODB.Connection")
On Error Resume Next
conn.Open connStr
If Err.Number <> 0 Then
WScript.Echo "DB connection failed: " & Err.Description
WScript.Quit 1
End If
On Error GoTo 0

'---------------- Discover schema (portable) ----------------
' Strategy:
' 1) Try OpenSchema(adSchemaColumns) for rich metadata.
' 2) Fallback to "SELECT * WHERE 1=0" to at least get names/types.
Const adSchemaColumns = 4

Dim cols(), types(), nullable(), ordinals(), fld, idx
Dim haveSchema : haveSchema = False

On Error Resume Next
Dim rsCols
Set rsCols = conn.OpenSchema(adSchemaColumns, Array(Empty, Empty, tableName, Empty))
If Err.Number = 0 Then
idx = -1
Do Until rsCols.EOF
idx = idx + 1
ReDim Preserve cols(idx), types(idx), nullable(idx), ordinals(idx)
cols(idx) = CStr(rsCols("COLUMN_NAME"))
types(idx) = Nz(rsCols("DATA_TYPE"), 0) ' ADO type enum
nullable(idx) = LCase(CStr(Nz(rsCols("IS_NULLABLE"), "YES"))) = "yes"
ordinals(idx) = CLng(Nz(rsCols("ORDINAL_POSITION"), idx+1))
rsCols.MoveNext
Loop
rsCols.Close : Set rsCols = Nothing
haveSchema = (idx >= 0)
Else
Err.Clear
End If
On Error GoTo 0

If Not haveSchema Then
' Fallback: get names/types from zero-row select
On Error Resume Next
Dim rsProbe
Set rsProbe = conn.Execute("SELECT * FROM " & QI(tableName) & " WHERE 1=0")
If Err.Number <> 0 Then
WScript.Echo "Error querying table [" & tableName & "]: " & Err.Description
conn.Close : Set conn = Nothing
WScript.Quit 1
End If
On Error GoTo 0

idx = -1
For Each fld In rsProbe.Fields
idx = idx + 1
ReDim Preserve cols(idx), types(idx), nullable(idx), ordinals(idx)
cols(idx) = fld.Name
types(idx) = fld.Type
nullable(idx) = True ' Unknown; assume nullable
ordinals(idx) = idx + 1
Next
rsProbe.Close : Set rsProbe = Nothing
End If

If idx < 0 Then
WScript.Echo "No columns found for table [" & tableName & "]."
WScript.Quit 1
End If

' Sort metadata by ordinal (defensive)
Call ArraySortByParallel(ordinals, Array(cols, types, nullable))

' Validate PK exists
If Not InArrayInsensitive(cols, primaryKey) Then
WScript.Echo "Primary key '" & primaryKey & "' not found in table [" & tableName & "]."
WScript.Quit 1
End If

'---------------- Generate POBO_<Table>.asp ----------------
Dim poboOut
poboOut = BuildPOBO(cols, types, tableName, primaryKey)

Dim poboPath, tf
poboPath = fso.BuildPath(thisFolder, "POBO_" & tableName & ".asp")
Set tf = fso.CreateTextFile(poboPath, True, False)
tf.Write poboOut
tf.Close
Set tf = Nothing
WScript.Echo "POBO class written to: " & poboPath

'---------------- Generate <Table>Repository.asp ----------------
Dim repoOut
repoOut = BuildRepository(cols, tableName, primaryKey)

Dim repoPath
repoPath = fso.BuildPath(thisFolder, tableName & "Repository.asp")
Set tf = fso.CreateTextFile(repoPath, True, False)
tf.Write repoOut
tf.Close
Set tf = Nothing
WScript.Echo "Repository written to: " & repoPath

'---------------- Cleanup ----------------
conn.Close : Set conn = Nothing
Set fso = Nothing

'==============================================================
' POBO generator (your example, integrated)
'==============================================================
Function BuildPOBO(byRef colsArr, byRef typesArr, ByVal tName, ByVal pk)
Dim classDef, idxLocal, name, ftype
Dim parts()
ReDim parts(1000) ' Pre-allocate for performance
Dim partIdx : partIdx = 0

' Build using array for performance (StringBuilder pattern)
parts(partIdx) = "<%" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = "' Auto-generated POBO for table [" & tName & "]" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = "' Generated on " & Now() & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = "' Generator: GenerateRepo.vbs v1.0" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = "'" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = "' Dependencies: core/helpers.asp (QuoteValue function)" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = vbCrLf & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = "Class POBO_" & tName & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " ' Public array of all property names" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " Public Properties" & vbCrLf & vbCrLf : partIdx = partIdx + 1

' Private backing fields
For idxLocal = 0 To UBound(colsArr)
parts(partIdx) = " Private p" & colsArr(idxLocal) & vbCrLf : partIdx = partIdx + 1
Next

' Initializer with defaults
parts(partIdx) = vbCrLf & " Private Sub Class_Initialize()" & vbCrLf : partIdx = partIdx + 1
For idxLocal = 0 To UBound(colsArr)
Select Case typesArr(idxLocal)
Case 200,201,202,203 ' adChar, adVarChar, adVarWChar, adWChar (strings)
parts(partIdx) = " p" & colsArr(idxLocal) & " = """"" & vbCrLf : partIdx = partIdx + 1
Case 7,133,135 ' adDate, adDBDate, adDBTimeStamp (dates)
parts(partIdx) = " p" & colsArr(idxLocal) & " = #1/1/1970#" & vbCrLf : partIdx = partIdx + 1
Case 2,3,4,5,6,14,131 ' adSmallInt, adInteger, adSingle, adDouble, adCurrency, adDecimal, adNumeric
parts(partIdx) = " p" & colsArr(idxLocal) & " = 0" & vbCrLf : partIdx = partIdx + 1
Case 11 ' adBoolean
parts(partIdx) = " p" & colsArr(idxLocal) & " = False" & vbCrLf : partIdx = partIdx + 1
Case Else
parts(partIdx) = " p" & colsArr(idxLocal) & " = Null" & vbCrLf : partIdx = partIdx + 1
End Select
Next

parts(partIdx) = " Properties = Array(""" & Join(colsArr, """,""") & """)" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " End Sub" & vbCrLf & vbCrLf : partIdx = partIdx + 1

parts(partIdx) = " Public Property Get PrimaryKey()" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " PrimaryKey = """ & pk & """" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1

parts(partIdx) = " Public Property Get TableName()" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " TableName = """ & tName & """" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1

' Get/Let with coercion
For idxLocal = 0 To UBound(colsArr)
name = colsArr(idxLocal)
ftype = typesArr(idxLocal)

parts(partIdx) = " Public Property Get " & name & "()" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " " & name & " = p" & name & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1

parts(partIdx) = " Public Property Let " & name & "(val)" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " On Error Resume Next" & vbCrLf : partIdx = partIdx + 1

Select Case ftype
Case 200,201,202,203 ' Strings
parts(partIdx) = " p" & name & " = CStr(val)" & vbCrLf : partIdx = partIdx + 1
Case 7 ' Dates
parts(partIdx) = " p" & name & " = CDate(val)" & vbCrLf : partIdx = partIdx + 1
Case 133,135 ' Timestamps
parts(partIdx) = " p" & name & " = QuoteValue(val)" & vbCrLf : partIdx = partIdx + 1
Case 11 ' Boolean
parts(partIdx) = " p" & name & " = CBool(val)" & vbCrLf : partIdx = partIdx + 1
Case Else ' Numeric or other
parts(partIdx) = " If IsNumeric(val) Then" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " p" & name & " = CDbl(val)" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " Else" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " p" & name & " = val" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " End If" & vbCrLf : partIdx = partIdx + 1
End Select

parts(partIdx) = " If Err.Number <> 0 Then" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " Err.Raise Err.Number, ""POBO_" & tName & "." & name & """, ""Invalid value for " & name & ": "" & Err.Description" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " End If" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " On Error GoTo 0" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = " End Property" & vbCrLf & vbCrLf : partIdx = partIdx + 1
Next

parts(partIdx) = "End Class" & vbCrLf : partIdx = partIdx + 1
parts(partIdx) = "%>" & vbCrLf : partIdx = partIdx + 1

' Join array for performance
ReDim Preserve parts(partIdx - 1)
BuildPOBO = Join(parts, "")
End Function

'==============================================================
' Repository generator (parameterized; DAL.* expected)
'==============================================================
Function BuildRepository(byRef colsArr, ByVal tName, ByVal pk)
Dim insertCols(), updateCols(), allCols(), idCol
Dim iLocal, cName
idCol = pk

' Copy columns (no array-to-array assignment in VBScript)
ReDim allCols(UBound(colsArr))
For iLocal = 0 To UBound(colsArr)
allCols(iLocal) = colsArr(iLocal)
Next

' Insert/Update sets: exclude PK
Dim insIdx : insIdx = -1
For Each cName In colsArr
If Not StrEqualCI(cName, idCol) Then
insIdx = insIdx + 1
ReDim Preserve insertCols(insIdx)
insertCols(insIdx) = cName
End If
Next

Dim updIdx : updIdx = -1
For Each cName In colsArr
If Not StrEqualCI(cName, idCol) Then
updIdx = updIdx + 1
ReDim Preserve updateCols(updIdx)
updateCols(updIdx) = cName
End If
Next

Dim QTable, QPK, selectList, selectBase
QTable = QI(tName)
QPK = QI(idCol)
selectList = JoinQI(allCols, ", ")
selectBase = "Select " & selectList & " FROM " & QTable

Dim out
out = out & "<%" & vbCrLf
out = out & "' Auto-generated Repository for table [" & tName & "]" & vbCrLf
out = out & "' Generated on " & Now() & vbCrLf
out = out & "' Generator: GenerateRepo.vbs v1.0" & vbCrLf
out = out & "'" & vbCrLf
out = out & "' Dependencies:" & vbCrLf
out = out & "' - core/lib.DAL.asp (DAL singleton for database access)" & vbCrLf
out = out & "' - core/lib.AutoMapper.asp (Automapper for object mapping)" & vbCrLf
out = out & "' - core/lib.Collections.asp (LinkedList_Class)" & vbCrLf
out = out & "' - core/lib.helpers.asp (KVUnzip, BuildOrderBy, QI, Destroy)" & vbCrLf
out = out & vbCrLf & vbCrLf

Dim className : className = tName & "Repository_Class"
out = out & "Class " & className & vbCrLf & vbCrLf

' FindByID
out = out & " Public Function FindByID(id)" & vbCrLf
out = out & " Dim sql : sql = """ & selectBase & " WHERE " & QPK & " = ?""" & vbCrLf
out = out & " Dim rs : Set rs = DAL.Query(sql, Array(id))" & vbCrLf
out = out & " If rs.EOF Then" & vbCrLf
out = out & " Err.Raise 1, """ & className & """, RecordNotFoundException(""" & idCol & """, id)" & vbCrLf
out = out & " Else" & vbCrLf
out = out & " Set FindByID = Automapper.AutoMap(rs, ""POBO_" & tName & """)" & vbCrLf
out = out & " End If" & vbCrLf
out = out & " Destroy rs" & vbCrLf
out = out & " End Function" & vbCrLf & vbCrLf

' GetAll -> Find
out = out & " Public Function GetAll(orderBy)" & vbCrLf
out = out & " Set GetAll = Find(Empty, orderBy)" & vbCrLf
out = out & " End Function" & vbCrLf & vbCrLf

' Find
out = out & " Public Function Find(where_kvarray, order_string_or_array)" & vbCrLf
out = out & " Dim sql : sql = """ & selectBase & """" & vbCrLf
out = out & " Dim where_keys, where_values, i" & vbCrLf
out = out & " If Not IsEmpty(where_kvarray) Then" & vbCrLf
out = out & " KVUnzip where_kvarray, where_keys, where_values" & vbCrLf
out = out & " If Not IsEmpty(where_keys) Then" & vbCrLf
out = out & " sql = sql & "" WHERE """ & vbCrLf
out = out & " For i = 0 To UBound(where_keys)" & vbCrLf
out = out & " If i > 0 Then sql = sql & "" AND """ & vbCrLf
out = out & " sql = sql & "" "" & QI(where_keys(i)) & "" = ?""" & vbCrLf
out = out & " Next" & vbCrLf
out = out & " End If" & vbCrLf
out = out & " End If" & vbCrLf
out = out & " sql = sql & BuildOrderBy(order_string_or_array, """ & QPK & """)" & vbCrLf
out = out & " Dim rs : Set rs = DAL.Query(sql, where_values)" & vbCrLf
out = out & " Dim list : Set list = new LinkedList_Class" & vbCrLf
out = out & " Do Until rs.EOF" & vbCrLf
out = out & " list.Push Automapper.AutoMap(rs, ""POBO_" & tName & """)" & vbCrLf
out = out & " rs.MoveNext" & vbCrLf
out = out & " Loop" & vbCrLf
out = out & " Set Find = list" & vbCrLf
out = out & " Destroy rs" & vbCrLf
out = out & " End Function" & vbCrLf & vbCrLf

' FindPaged
out = out & " Public Function FindPaged(where_kvarray, order_string_or_array, per_page, page_num, ByRef page_count, ByRef record_count)" & vbCrLf
out = out & " Dim sql : sql = """ & selectBase & """" & vbCrLf
out = out & " Dim where_keys, where_values, i" & vbCrLf
out = out & " If Not IsEmpty(where_kvarray) Then" & vbCrLf
out = out & " KVUnzip where_kvarray, where_keys, where_values" & vbCrLf
out = out & " If Not IsEmpty(where_keys) Then" & vbCrLf
out = out & " sql = sql & "" WHERE """ & vbCrLf
out = out & " For i = 0 To UBound(where_keys)" & vbCrLf
out = out & " If i > 0 Then sql = sql & "" AND """ & vbCrLf
out = out & " sql = sql & "" "" & QI(where_keys(i)) & "" = ?""" & vbCrLf
out = out & " Next" & vbCrLf
out = out & " End If" & vbCrLf
out = out & " End If" & vbCrLf
out = out & " sql = sql & BuildOrderBy(order_string_or_array, """ & QPK & """)" & vbCrLf
out = out & " Dim rs : Set rs = DAL.PagedQuery(sql, where_values, per_page, page_num)" & vbCrLf
out = out & " If Not rs.EOF Then" & vbCrLf
out = out & " rs.PageSize = per_page" & vbCrLf
out = out & " rs.AbsolutePage = page_num" & vbCrLf
out = out & " page_count = rs.PageCount" & vbCrLf
out = out & " record_count = rs.RecordCount" & vbCrLf
out = out & " End If" & vbCrLf
out = out & " Set FindPaged = PagedList(rs, per_page)" & vbCrLf
out = out & " Destroy rs" & vbCrLf
out = out & " End Function" & vbCrLf & vbCrLf

' SearchTablePaged (OR col LIKE ?)
out = out & " Public Function SearchTablePaged(columns_array, search_value, order_string_or_array, per_page, page_num, ByRef page_count, ByRef record_count)" & vbCrLf
out = out & " Dim sql : sql = """ & selectBase & """" & vbCrLf
out = out & " Dim i, params()" & vbCrLf
out = out & " If IsArray(columns_array) And UBound(columns_array) >= 0 Then" & vbCrLf
out = out & " sql = sql & "" WHERE """ & vbCrLf
out = out & " ReDim params(UBound(columns_array))" & vbCrLf
out = out & " For i = 0 To UBound(columns_array)" & vbCrLf
out = out & " If i > 0 Then sql = sql & "" OR """ & vbCrLf
out = out & " sql = sql & "" "" & QI(columns_array(i)) & "" LIKE ?""" & vbCrLf
out = out & " params(i) = ""%"" & search_value & ""%""" & vbCrLf
out = out & " Next" & vbCrLf
out = out & " End If" & vbCrLf
out = out & " sql = sql & BuildOrderBy(order_string_or_array, """ & QPK & """)" & vbCrLf
out = out & " Dim rs : Set rs = DAL.PagedQuery(sql, params, per_page, page_num)" & vbCrLf
out = out & " If Not rs.EOF Then" & vbCrLf
out = out & " rs.PageSize = per_page" & vbCrLf
out = out & " rs.AbsolutePage = page_num" & vbCrLf
out = out & " page_count = rs.PageCount" & vbCrLf
out = out & " record_count = rs.RecordCount" & vbCrLf
out = out & " End If" & vbCrLf
out = out & " Set SearchTablePaged = PagedList(rs, per_page)" & vbCrLf
out = out & " Destroy rs" & vbCrLf
out = out & " End Function" & vbCrLf & vbCrLf

' PagedList helper
out = out & " Private Function PagedList(rs, per_page)" & vbCrLf
out = out & " Dim list : Set list = new LinkedList_Class" & vbCrLf
out = out & " Dim x : x = 0" & vbCrLf
out = out & " Do While (per_page <= 0 Or x < per_page) And Not rs.EOF" & vbCrLf
out = out & " list.Push Automapper.AutoMap(rs, ""POBO_" & tName & """)" & vbCrLf
out = out & " x = x + 1" & vbCrLf
out = out & " rs.MoveNext" & vbCrLf
out = out & " Loop" & vbCrLf
out = out & " Set PagedList = list" & vbCrLf
out = out & " End Function" & vbCrLf & vbCrLf

' AddNew
out = out & " Public Sub AddNew(ByRef model)" & vbCrLf
out = out & " Dim sql : sql = ""INSERT INTO " & QTable & " (" & JoinQI(insertCols, ", ") & ") VALUES (" & Placeholders(UBound(insertCols)+1) & ")""" & vbCrLf
out = out & " DAL.Execute sql, " & BuildModelParamsArray("model", insertCols) & vbCrLf
out = out & " " & vbCrLf
out = out & " ' Retrieve the newly inserted ID" & vbCrLf
out = out & " On Error Resume Next" & vbCrLf
out = out & " Dim rsId : Set rsId = DAL.Query(""SELECT @@IDENTITY AS NewID"", Empty)" & vbCrLf
out = out & " If Err.Number <> 0 Then" & vbCrLf
out = out & " ' Fallback for Access databases" & vbCrLf
out = out & " Err.Clear" & vbCrLf
out = out & " Set rsId = DAL.Query(""SELECT TOP 1 " & QPK & " FROM " & QTable & " ORDER BY " & QPK & " DESC"", Empty)" & vbCrLf
out = out & " End If" & vbCrLf
out = out & " On Error GoTo 0" & vbCrLf
out = out & " " & vbCrLf
out = out & " If Not rsId.EOF Then" & vbCrLf
out = out & " If Not IsNull(rsId(0)) Then model." & idCol & " = rsId(0)" & vbCrLf
out = out & " End If" & vbCrLf
out = out & " Destroy rsId" & vbCrLf
out = out & " End Sub" & vbCrLf & vbCrLf

' Update
out = out & " Public Sub Update(model)" & vbCrLf
out = out & " Dim sql : sql = ""UPDATE " & QTable & " SET " & JoinSetters(updateCols) & " WHERE " & QPK & " = ?""" & vbCrLf
out = out & " DAL.Execute sql, " & BuildModelParamsArrayWithPK("model", updateCols, idCol) & vbCrLf
out = out & " End Sub" & vbCrLf & vbCrLf

' Delete
out = out & " Public Sub Delete(id)" & vbCrLf
out = out & " Dim sql : sql = ""DELETE FROM " & QTable & " WHERE " & QPK & " = ?""" & vbCrLf
out = out & " DAL.Execute sql, Array(id)" & vbCrLf
out = out & " End Sub" & vbCrLf & vbCrLf

' Exceptions & helpers
out = out & " Private Function RecordNotFoundException(ByVal field_name, ByVal field_val)" & vbCrLf
out = out & " RecordNotFoundException = """ & tName & " record was not found with "" & field_name & "" = '"" & field_val & ""'.""" & vbCrLf
out = out & " End Function" & vbCrLf & vbCrLf

out = out & " Private Function QI(name)" & vbCrLf
out = out & " QI = ""["" & Replace(CStr(name), ""]"", ""]]"") & ""]""" & vbCrLf
out = out & " End Function" & vbCrLf & vbCrLf

out = out & " Private Function BuildOrderBy(orderArg, defaultCol)" & vbCrLf
out = out & " Dim s : s = """"" & vbCrLf
out = out & " If IsEmpty(orderArg) Or IsNull(orderArg) Or orderArg = """" Then" & vbCrLf
out = out & " s = "" ORDER BY "" & defaultCol & "" ASC""" & vbCrLf
out = out & " ElseIf IsArray(orderArg) Then" & vbCrLf
out = out & " Dim i : s = "" ORDER BY """ & vbCrLf
out = out & " For i = 0 To UBound(orderArg)" & vbCrLf
out = out & " If i > 0 Then s = s & "", """ & vbCrLf
out = out & " s = s & QI(orderArg(i))" & vbCrLf
out = out & " Next" & vbCrLf
out = out & " Else" & vbCrLf
out = out & " s = "" ORDER BY "" & QI(orderArg)" & vbCrLf
out = out & " End If" & vbCrLf
out = out & " BuildOrderBy = s" & vbCrLf
out = out & " End Function" & vbCrLf

out = out & "End Class" & vbCrLf & vbCrLf

out = out & "Dim " & tName & "Repository__Singleton" & vbCrLf
out = out & "Function " & tName & "Repository()" & vbCrLf
out = out & " If IsEmpty(" & tName & "Repository__Singleton) Then" & vbCrLf
out = out & " Set " & tName & "Repository__Singleton = new " & className & vbCrLf
out = out & " End If" & vbCrLf
out = out & " Set " & tName & "Repository = " & tName & "Repository__Singleton" & vbCrLf
out = out & "End Function" & vbCrLf

out = out & "%>" & vbCrLf

BuildRepository = out
End Function

'==============================================================
' Helpers (generator side)
'==============================================================
Function GetAppSetting(key, configFilePath)
Dim xml, nodes, node, j, localFso
Set localFso = CreateObject("Scripting.FileSystemObject")
Set xml = CreateObject("Microsoft.XMLDOM")
If Not localFso.FileExists(configFilePath) Then
GetAppSetting = "nothing" : Exit Function
End If
xml.Async = False
xml.Load(configFilePath)
If xml.ParseError.ErrorCode <> 0 Then
GetAppSetting = "nothing" : Exit Function
End If
Set nodes = xml.selectNodes("//appSettings/add")
For j = 0 To nodes.Length - 1
Set node = nodes.Item(j)
If node.getAttribute("key") = key Then
GetAppSetting = node.getAttribute("value")
Exit Function
End If
Next
GetAppSetting = "nothing"
End Function

Function Nz(val, defaultVal)
If IsNull(val) Or IsEmpty(val) Then
Nz = defaultVal
Else
Nz = val
End If
End Function

Sub ArraySortByParallel(keys, arrs)
Dim iLocal, jLocal, kLocal, tmpKey, tmp
For iLocal = 0 To UBound(keys) - 1
For jLocal = iLocal + 1 To UBound(keys)
If keys(jLocal) < keys(iLocal) Then
tmpKey = keys(iLocal) : keys(iLocal) = keys(jLocal) : keys(jLocal) = tmpKey
For kLocal = 0 To UBound(arrs)
tmp = arrs(kLocal)(iLocal)
arrs(kLocal)(iLocal) = arrs(kLocal)(jLocal)
arrs(kLocal)(jLocal) = tmp
Next
End If
Next
Next
End Sub

Function InArrayInsensitive(a, val)
Dim z
InArrayInsensitive = False
For z = 0 To UBound(a)
If StrEqualCI(a(z), val) Then InArrayInsensitive = True : Exit Function
Next
End Function

Function StrEqualCI(a, b)
StrEqualCI = (LCase(CStr(a)) = LCase(CStr(b)))
End Function

Function QI(name)
QI = "[" & Replace(CStr(name), "]", "]]") & "]"
End Function

Function JoinQI(a, sep)
Dim j, s : s = ""
For j = 0 To UBound(a)
If j > 0 Then s = s & sep
s = s & QI(a(j))
Next
JoinQI = s
End Function

Function Placeholders(n)
Dim j, s : s = ""
For j = 1 To n
If j > 1 Then s = s & ", "
s = s & "?"
Next
Placeholders = s
End Function

Function JoinSetters(a)
Dim j, s : s = ""
For j = 0 To UBound(a)
If j > 0 Then s = s & ", "
s = s & QI(a(j)) & " = ?"
Next
JoinSetters = s
End Function

Function BuildModelParamsArray(modelName, a)
Dim j, s : s = "Array("
For j = 0 To UBound(a)
If j > 0 Then s = s & ", "
s = s & modelName & "." & a(j)
Next
s = s & ")"
BuildModelParamsArray = s
End Function

Function BuildModelParamsArrayWithPK(modelName, a, pk)
Dim j, s : s = "Array("
For j = 0 To UBound(a)
If j > 0 Then s = s & ", "
s = s & modelName & "." & a(j)
Next
s = s & ", " & modelName & "." & pk & ")"
BuildModelParamsArrayWithPK = s
End Function

' Validate identifier (table name, column name, etc.)
Function IsValidIdentifier(name)
If IsEmpty(name) Or Len(name) = 0 Then
IsValidIdentifier = False
Exit Function
End If

Dim i, ch
For i = 1 To Len(name)
ch = Mid(name, i, 1)
' Allow a-z, A-Z, 0-9, and underscore only
If Not ((ch >= "a" And ch <= "z") Or _
(ch >= "A" And ch <= "Z") Or _
(ch >= "0" And ch <= "9") Or _
ch = "_") Then
IsValidIdentifier = False
Exit Function
End If
Next

IsValidIdentifier = True
End Function

二进制
scripts/generateController.vbs 查看文件


+ 162
- 0
scripts/generateMigration.vbs 查看文件

@@ -0,0 +1,162 @@
'=======================================================================================================================
' MIGRATION GENERATOR
'=======================================================================================================================
' Generates a new migration file with timestamp-based versioning.
'
' Usage:
' cscript //nologo scripts\generateMigration.vbs migration_name
'
' Example:
' cscript //nologo scripts\generateMigration.vbs create_users_table
' Creates: db/migrations/20260109153045_create_users_table.asp
'

Option Explicit

Dim fso, migrationName, timestamp, filename, filepath, content

Set fso = CreateObject("Scripting.FileSystemObject")

' Check arguments
If WScript.Arguments.Count < 1 Then
WScript.Echo "Usage: cscript //nologo scripts\generateMigration.vbs migration_name"
WScript.Echo ""
WScript.Echo "Example:"
WScript.Echo " cscript //nologo scripts\generateMigration.vbs create_users_table"
WScript.Quit 1
End If

migrationName = WScript.Arguments(0)

' Validate migration name (alphanumeric and underscore only)
If Not IsValidMigrationName(migrationName) Then
WScript.Echo "Error: Migration name must contain only letters, numbers, and underscores"
WScript.Quit 1
End If

' Generate timestamp (YYYYMMDDHHMMSS)
timestamp = GetTimestamp()

' Create filename
filename = timestamp & "_" & migrationName & ".asp"

' Ensure migrations directory exists
Dim migrationsDir
migrationsDir = fso.GetParentFolderName(WScript.ScriptFullName) & "\..\db\migrations"
migrationsDir = fso.GetAbsolutePathName(migrationsDir)

If Not fso.FolderExists(migrationsDir) Then
CreateDirectoryPath migrationsDir
End If

filepath = migrationsDir & "\" & filename

' Check if file already exists
If fso.FileExists(filepath) Then
WScript.Echo "Error: Migration file already exists: " & filename
WScript.Quit 1
End If

' Generate migration content
content = GenerateMigrationContent(migrationName)

' Write the file
Dim file
Set file = fso.CreateTextFile(filepath, True)
file.Write content
file.Close

WScript.Echo "Migration created: " & filename
WScript.Echo "Path: " & filepath
WScript.Echo ""
WScript.Echo "Edit the file to add your migration logic, then run:"
WScript.Echo " cscript //nologo scripts\runMigrations.vbs"

WScript.Quit 0

'=======================================================================================================================
' HELPER FUNCTIONS
'=======================================================================================================================

Function GetTimestamp()
Dim dtNow, sYear, sMonth, sDay, sHour, sMinute, sSecond
dtNow = Now()

sYear = Year(dtNow)
sMonth = Right("0" & Month(dtNow), 2)
sDay = Right("0" & Day(dtNow), 2)
sHour = Right("0" & Hour(dtNow), 2)
sMinute = Right("0" & Minute(dtNow), 2)
sSecond = Right("0" & Second(dtNow), 2)

GetTimestamp = sYear & sMonth & sDay & sHour & sMinute & sSecond
End Function

Function IsValidMigrationName(name)
Dim regex
Set regex = New RegExp
regex.Pattern = "^[a-zA-Z0-9_]+$"
IsValidMigrationName = regex.Test(name)
End Function

Function GenerateMigrationContent(name)
Dim template

template = "<%"& vbCrLf
template = template & "'======================================================================================================================="& vbCrLf
template = template & "' MIGRATION: " & name & vbCrLf
template = template & "'======================================================================================================================="& vbCrLf
template = template & "' This migration was auto-generated. Add your migration logic below."& vbCrLf
template = template & "'"& vbCrLf
template = template & "' The migration object provides these helper methods:"& vbCrLf
template = template & "' - migration.ExecuteSQL(sql) - Execute raw SQL"& vbCrLf
template = template & "' - migration.CreateTable(name, columns) - Create a table"& vbCrLf
template = template & "' - migration.DropTable(name) - Drop a table"& vbCrLf
template = template & "' - migration.AddColumn(table, column, type) - Add a column"& vbCrLf
template = template & "' - migration.DropColumn(table, column) - Drop a column"& vbCrLf
template = template & "' - migration.CreateIndex(name, table, columns) - Create an index"& vbCrLf
template = template & "' - migration.DropIndex(name, table) - Drop an index"& vbCrLf
template = template & "'"& vbCrLf
template = template & "' For complex operations, use migration.DB to access the database directly:"& vbCrLf
template = template & "' migration.DB.Execute ""INSERT INTO users (name) VALUES (?)"", Array(""John"")"& vbCrLf
template = template & "'"& vbCrLf
template = template & ""& vbCrLf
template = template & "'-----------------------------------------------------------------------------------------------------------------------"& vbCrLf
template = template & "' UP - Apply the migration"& vbCrLf
template = template & "'-----------------------------------------------------------------------------------------------------------------------"& vbCrLf
template = template & "Sub Migration_Up(migration)"& vbCrLf
template = template & " ' Example: Create a table"& vbCrLf
template = template & " ' migration.CreateTable ""users"", ""id AUTOINCREMENT PRIMARY KEY, name VARCHAR(255) NOT NULL, email VARCHAR(255), created_at DATETIME"""& vbCrLf
template = template & " "& vbCrLf
template = template & " ' Example: Add an index"& vbCrLf
template = template & " ' migration.CreateIndex ""idx_users_email"", ""users"", ""email"""& vbCrLf
template = template & " "& vbCrLf
template = template & " ' TODO: Add your migration logic here"& vbCrLf
template = template & " "& vbCrLf
template = template & "End Sub"& vbCrLf
template = template & ""& vbCrLf
template = template & "'-----------------------------------------------------------------------------------------------------------------------"& vbCrLf
template = template & "' DOWN - Rollback the migration"& vbCrLf
template = template & "'-----------------------------------------------------------------------------------------------------------------------"& vbCrLf
template = template & "Sub Migration_Down(migration)"& vbCrLf
template = template & " ' Example: Drop the table"& vbCrLf
template = template & " ' migration.DropTable ""users"""& vbCrLf
template = template & " "& vbCrLf
template = template & " ' TODO: Add your rollback logic here (reverse the Up migration)"& vbCrLf
template = template & " "& vbCrLf
template = template & "End Sub"& vbCrLf
template = template & "%>"& vbCrLf

GenerateMigrationContent = template
End Function

Sub CreateDirectoryPath(path)
Dim parentPath
If Not fso.FolderExists(path) Then
parentPath = fso.GetParentFolderName(path)
If parentPath <> "" Then
CreateDirectoryPath parentPath
End If
fso.CreateFolder path
End If
End Sub

+ 614
- 0
scripts/runMigrations.vbs 查看文件

@@ -0,0 +1,614 @@
'=======================================================================================================================
' MIGRATION RUNNER (Standalone VBScript)
'=======================================================================================================================
' Runs database migrations directly via VBScript without requiring IIS/ASP.
'
' Usage:
' cscript //nologo scripts\runMigrations.vbs [command]
'
' Commands:
' up - Apply all pending migrations (default)
' down - Rollback the last migration
' status - Show migration status
' apply <file> - Apply a specific migration file
' rollback <file> - Rollback a specific migration file
'
' Examples:
' cscript //nologo scripts\runMigrations.vbs
' cscript //nologo scripts\runMigrations.vbs up
' cscript //nologo scripts\runMigrations.vbs down
' cscript //nologo scripts\runMigrations.vbs status
'

Option Explicit

Dim fso, scriptDir, projectRoot, webConfigPath, migrationsPath
Dim connectionString, command, argument

Set fso = CreateObject("Scripting.FileSystemObject")

' Get paths
scriptDir = fso.GetParentFolderName(WScript.ScriptFullName)
projectRoot = fso.GetAbsolutePathName(scriptDir & "\..")
webConfigPath = projectRoot & "\public\web.config"
migrationsPath = projectRoot & "\db\migrations"

' Parse arguments
command = "up" ' default command
If WScript.Arguments.Count > 0 Then
command = LCase(WScript.Arguments(0))
End If

If WScript.Arguments.Count > 1 Then
argument = WScript.Arguments(1)
End If

' Validate command
Select Case command
Case "up", "down", "status", "apply", "rollback"
' Valid command
Case Else
ShowUsage
WScript.Quit 1
End Select

' Load connection string from web.config
connectionString = GetConnectionString(webConfigPath)
If connectionString = "" Then
WScript.Echo "Error: Could not read connection string from web.config"
WScript.Quit 1
End If

' Execute the command
On Error Resume Next
Select Case command
Case "up"
ApplyAllPending
Case "down"
RollbackLast
Case "status"
ShowStatus
Case "apply"
If argument = "" Then
WScript.Echo "Error: No migration file specified"
WScript.Echo "Usage: cscript //nologo scripts\runMigrations.vbs apply <filename>"
WScript.Quit 1
End If
ApplyMigration argument
Case "rollback"
If argument = "" Then
WScript.Echo "Error: No migration file specified"
WScript.Echo "Usage: cscript //nologo scripts\runMigrations.vbs rollback <filename>"
WScript.Quit 1
End If
RollbackMigration argument
End Select

If Err.Number <> 0 Then
WScript.Echo ""
WScript.Echo "ERROR: " & Err.Description
WScript.Echo "Number: " & Err.Number
WScript.Echo "Source: " & Err.Source
WScript.Quit 1
End If

WScript.Quit 0

'=======================================================================================================================
' MIGRATION FUNCTIONS
'=======================================================================================================================

Sub ApplyAllPending()
WScript.Echo "=============================================================="
WScript.Echo "APPLYING PENDING MIGRATIONS"
WScript.Echo "=============================================================="
WScript.Echo ""

EnsureSchemaMigrationsTable

Dim pending, version, versions(), i, j, temp
Set pending = GetPendingMigrations()

If pending.Count = 0 Then
WScript.Echo "No pending migrations."
WScript.Echo ""
WScript.Echo "=============================================================="
WScript.Echo "DONE"
WScript.Echo "=============================================================="
Exit Sub
End If

' Sort versions
ReDim versions(pending.Count - 1)
i = 0
For Each version In pending.Keys
versions(i) = version
i = i + 1
Next

' Simple bubble sort (string comparison works for YYYYMMDDHHMMSS format)
For i = 0 To UBound(versions) - 1
For j = i + 1 To UBound(versions)
If versions(i) > versions(j) Then
temp = versions(i)
versions(i) = versions(j)
versions(j) = temp
End If
Next
Next

' Apply in order
For i = 0 To UBound(versions)
ApplyMigration pending(versions(i))
Next

WScript.Echo ""
WScript.Echo "=============================================================="
WScript.Echo "DONE"
WScript.Echo "=============================================================="
End Sub

Sub RollbackLast()
WScript.Echo "=============================================================="
WScript.Echo "ROLLING BACK LAST MIGRATION"
WScript.Echo "=============================================================="
WScript.Echo ""

EnsureSchemaMigrationsTable

Dim applied, available, version, lastVersion, filename
Set applied = GetAppliedMigrations()

If applied.Count = 0 Then
WScript.Echo "No migrations to rollback."
WScript.Echo ""
WScript.Echo "=============================================================="
WScript.Echo "DONE"
WScript.Echo "=============================================================="
Exit Sub
End If

' Find the last version (string comparison works for YYYYMMDDHHMMSS format)
lastVersion = ""
For Each version In applied.Keys
If lastVersion = "" Or version > lastVersion Then
lastVersion = version
End If
Next

' Find the filename
Set available = GetAvailableMigrations()
If available.Exists(lastVersion) Then
filename = available(lastVersion)
RollbackMigration filename
Else
WScript.Echo "Error: Migration file not found for version: " & lastVersion
WScript.Quit 1
End If

WScript.Echo ""
WScript.Echo "=============================================================="
WScript.Echo "DONE"
WScript.Echo "=============================================================="
End Sub

Sub ShowStatus()
WScript.Echo "=============================================================="
WScript.Echo "MIGRATION STATUS"
WScript.Echo "=============================================================="
WScript.Echo ""

EnsureSchemaMigrationsTable

Dim applied, pending, available, version
Set applied = GetAppliedMigrations()
Set pending = GetPendingMigrations()
Set available = GetAvailableMigrations()

WScript.Echo "Applied migrations: " & applied.Count
If applied.Count > 0 Then
For Each version In applied.Keys
If available.Exists(version) Then
WScript.Echo " [X] " & available(version)
Else
WScript.Echo " [X] " & version & " (file not found)"
End If
Next
End If

WScript.Echo ""
WScript.Echo "Pending migrations: " & pending.Count
If pending.Count > 0 Then
For Each version In pending.Keys
WScript.Echo " [ ] " & pending(version)
Next
End If

WScript.Echo ""
WScript.Echo "=============================================================="
End Sub

Sub ApplyMigration(filename)
Dim version
version = GetVersionFromFilename(filename)

If version = "" Then
Err.Raise vbObjectError + 1, "Migrator", "Invalid migration filename format: " & filename
End If

' Check if already applied
Dim applied
Set applied = GetAppliedMigrations()
If applied.Exists(version) Then
WScript.Echo "Migration " & version & " already applied. Skipping."
Exit Sub
End If

WScript.Echo "Applying migration: " & filename & "..."

' Execute the migration
' NOTE: Access/Jet does NOT support DDL (CREATE TABLE, etc.) inside transactions
' So we run without transaction wrapper and rely on error checking instead
Dim conn, migrationSuccess
Set conn = GetConnection()

On Error Resume Next
migrationSuccess = ExecuteMigrationFile(filename, "Up", conn)

If Err.Number <> 0 Then
WScript.Echo "ERROR: Migration failed - " & Err.Description
WScript.Echo "Error Number: " & Err.Number
conn.Close
Err.Raise vbObjectError + 2, "Migrator", "Migration failed: " & Err.Description
End If
On Error GoTo 0

' Check if migration had SQL errors
If Not migrationSuccess Then
WScript.Echo ""
WScript.Echo "ERROR: Migration failed due to SQL errors (see above)."
WScript.Echo "Migration NOT recorded. Please fix the migration and try again."
conn.Close
WScript.Quit 1
End If

' Record the migration
On Error Resume Next
Dim cmd
Set cmd = CreateObject("ADODB.Command")
Set cmd.ActiveConnection = conn
cmd.CommandText = "INSERT INTO schema_migrations (version, applied_at) VALUES (?, ?)"
cmd.Execute , Array(version, Now())

If Err.Number <> 0 Then
WScript.Echo "ERROR: Failed to record migration - " & Err.Description
conn.Close
Err.Raise vbObjectError + 3, "Migrator", "Failed to record migration: " & Err.Description
End If
On Error GoTo 0

conn.Close
WScript.Echo "Migration " & version & " applied successfully."
End Sub

Sub RollbackMigration(filename)
Dim version
version = GetVersionFromFilename(filename)

If version = "" Then
Err.Raise vbObjectError + 1, "Migrator", "Invalid migration filename format: " & filename
End If

' Check if applied
Dim applied
Set applied = GetAppliedMigrations()
If Not applied.Exists(version) Then
WScript.Echo "Migration " & version & " not applied. Skipping."
Exit Sub
End If

WScript.Echo "Rolling back migration: " & filename & "..."

' Execute the migration
' NOTE: Access/Jet does NOT support DDL (DROP TABLE, etc.) inside transactions
Dim conn, rollbackSuccess
Set conn = GetConnection()

On Error Resume Next
rollbackSuccess = ExecuteMigrationFile(filename, "Down", conn)

If Err.Number <> 0 Then
WScript.Echo "ERROR: Rollback failed - " & Err.Description
WScript.Echo "Error Number: " & Err.Number
conn.Close
Err.Raise vbObjectError + 4, "Migrator", "Rollback failed: " & Err.Description
End If
On Error GoTo 0

' Check if rollback had SQL errors
If Not rollbackSuccess Then
WScript.Echo ""
WScript.Echo "ERROR: Rollback failed due to SQL errors (see above)."
WScript.Echo "Migration record NOT removed. Please fix the issue manually."
conn.Close
WScript.Quit 1
End If

' Remove migration record
On Error Resume Next
Dim cmd
Set cmd = CreateObject("ADODB.Command")
Set cmd.ActiveConnection = conn
cmd.CommandText = "DELETE FROM schema_migrations WHERE version = ?"
cmd.Execute , Array(version)

If Err.Number <> 0 Then
WScript.Echo "ERROR: Failed to remove migration record - " & Err.Description
conn.Close
Err.Raise vbObjectError + 5, "Migrator", "Failed to remove migration record: " & Err.Description
End If
On Error GoTo 0

conn.Close
WScript.Echo "Migration " & version & " rolled back successfully."
End Sub

'=======================================================================================================================
' HELPER FUNCTIONS
'=======================================================================================================================

Sub ShowUsage()
WScript.Echo "Usage: cscript //nologo scripts\runMigrations.vbs [command]"
WScript.Echo ""
WScript.Echo "Commands:"
WScript.Echo " up - Apply all pending migrations (default)"
WScript.Echo " down - Rollback the last migration"
WScript.Echo " status - Show migration status"
WScript.Echo " apply <file> - Apply a specific migration file"
WScript.Echo " rollback <file> - Rollback a specific migration file"
WScript.Echo ""
WScript.Echo "Examples:"
WScript.Echo " cscript //nologo scripts\runMigrations.vbs"
WScript.Echo " cscript //nologo scripts\runMigrations.vbs up"
WScript.Echo " cscript //nologo scripts\runMigrations.vbs down"
WScript.Echo " cscript //nologo scripts\runMigrations.vbs status"
End Sub

Function GetConnectionString(configPath)
If Not fso.FileExists(configPath) Then
GetConnectionString = ""
Exit Function
End If

Dim xmlDoc, node
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
xmlDoc.async = False
xmlDoc.load configPath

Set node = xmlDoc.selectSingleNode("//appSettings/add[@key='ConnectionString']/@value")
If node Is Nothing Then
GetConnectionString = ""
Else
GetConnectionString = node.text
End If
End Function

Function GetConnection()
Dim conn
Set conn = CreateObject("ADODB.Connection")
conn.Open connectionString
Set GetConnection = conn
End Function

Sub EnsureSchemaMigrationsTable()
Dim conn, rs
Set conn = GetConnection()

On Error Resume Next
Set rs = conn.Execute("SELECT TOP 1 version FROM schema_migrations")

If Err.Number <> 0 Then
' Table doesn't exist, create it
Err.Clear
On Error GoTo 0

conn.Execute "CREATE TABLE schema_migrations (" & _
"version VARCHAR(14) PRIMARY KEY, " & _
"applied_at DATETIME NOT NULL)"
Else
If Not rs Is Nothing Then
If Not rs.EOF Then rs.Close
End If
End If

conn.Close
On Error GoTo 0
End Sub

Function GetAppliedMigrations()
Dim conn, rs, versions, version
Set conn = GetConnection()
Set versions = CreateObject("Scripting.Dictionary")

Set rs = conn.Execute("SELECT version FROM schema_migrations ORDER BY version")

Do While Not rs.EOF
version = Trim(rs("version"))
versions.Add version, True
rs.MoveNext
Loop

rs.Close
conn.Close

Set GetAppliedMigrations = versions
End Function

Function GetAvailableMigrations()
Dim folder, files, file, migrations, version
Set migrations = CreateObject("Scripting.Dictionary")

If Not fso.FolderExists(migrationsPath) Then
Set GetAvailableMigrations = migrations
Exit Function
End If

Set folder = fso.GetFolder(migrationsPath)
Set files = folder.Files

For Each file In files
If LCase(fso.GetExtensionName(file.Name)) = "asp" Then
version = GetVersionFromFilename(file.Name)
If version <> "" Then
migrations.Add version, file.Name
End If
End If
Next

Set GetAvailableMigrations = migrations
End Function

Function GetPendingMigrations()
Dim applied, available, pending, version
Set applied = GetAppliedMigrations()
Set available = GetAvailableMigrations()
Set pending = CreateObject("Scripting.Dictionary")

For Each version In available.Keys
If Not applied.Exists(version) Then
pending.Add version, available(version)
End If
Next

Set GetPendingMigrations = pending
End Function

Function GetVersionFromFilename(filename)
Dim parts
parts = Split(filename, "_")

If UBound(parts) >= 0 Then
Dim version
version = parts(0)
' Validate it's a 14-digit timestamp
If Len(version) = 14 And IsNumeric(version) Then
GetVersionFromFilename = version
Exit Function
End If
End If

GetVersionFromFilename = ""
End Function

' Global variable to hold migration context for error checking
Dim g_migrationContext

Function ExecuteMigrationFile(filename, direction, conn)
Dim migrationPath, fileContent, migration
migrationPath = migrationsPath & "\" & filename

If Not fso.FileExists(migrationPath) Then
Err.Raise vbObjectError + 6, "Migrator", "Migration file not found: " & migrationPath
End If

' Create migration context
Set migration = New MigrationContext
Set migration.Connection = conn
Set g_migrationContext = migration ' Store globally for error checking

' Read and execute the migration file
Dim stream
Set stream = fso.OpenTextFile(migrationPath, 1)
fileContent = stream.ReadAll
stream.Close

' Remove ASP tags
fileContent = Replace(fileContent, "<%", "")
fileContent = Replace(fileContent, "%>", "")

' Execute the migration code
ExecuteGlobal fileContent

' Call the appropriate method
If direction = "Up" Then
Migration_Up migration
ElseIf direction = "Down" Then
Migration_Down migration
End If

' Return True if successful, False if error
ExecuteMigrationFile = Not migration.HasError
End Function

'=======================================================================================================================
' MIGRATION CONTEXT CLASS
'=======================================================================================================================
Class MigrationContext
Public Connection
Public HasError
Public LastErrorMessage
Public LastErrorNumber

Private Sub Class_Initialize()
HasError = False
LastErrorMessage = ""
LastErrorNumber = 0
End Sub

Public Sub ExecuteSQL(sql)
If HasError Then Exit Sub ' Skip if previous error occurred

On Error Resume Next
Connection.Execute sql
If Err.Number <> 0 Then
HasError = True
LastErrorNumber = Err.Number
LastErrorMessage = "SQL Error: " & Err.Description & " (Error " & Err.Number & ")" & vbCrLf & "SQL: " & sql
WScript.Echo " ERROR executing SQL: " & Err.Description
WScript.Echo " Error Number: " & Err.Number
WScript.Echo " SQL: " & sql
Err.Clear
End If
On Error GoTo 0
End Sub

Public Sub CreateTable(tableName, columns)
If HasError Then Exit Sub
WScript.Echo " Creating table: " & tableName
ExecuteSQL "CREATE TABLE " & tableName & " (" & columns & ")"
End Sub

Public Sub DropTable(tableName)
If HasError Then Exit Sub
WScript.Echo " Dropping table: " & tableName
ExecuteSQL "DROP TABLE " & tableName
End Sub

Public Sub AddColumn(tableName, columnName, columnType)
If HasError Then Exit Sub
WScript.Echo " Adding column: " & tableName & "." & columnName
ExecuteSQL "ALTER TABLE " & tableName & " ADD COLUMN " & columnName & " " & columnType
End Sub

Public Sub DropColumn(tableName, columnName)
If HasError Then Exit Sub
WScript.Echo " Dropping column: " & tableName & "." & columnName
ExecuteSQL "ALTER TABLE " & tableName & " DROP COLUMN " & columnName
End Sub

Public Sub CreateIndex(indexName, tableName, columns)
If HasError Then Exit Sub
WScript.Echo " Creating index: " & indexName & " on " & tableName
ExecuteSQL "CREATE INDEX " & indexName & " ON " & tableName & " (" & columns & ")"
End Sub

Public Sub DropIndex(indexName, tableName)
If HasError Then Exit Sub
WScript.Echo " Dropping index: " & indexName & " on " & tableName
ExecuteSQL "DROP INDEX " & indexName & " ON " & tableName
End Sub

Public Function DB()
Set DB = Me
End Function
End Class

正在加载...
取消
保存

Powered by TurnKey Linux.