| @@ -0,0 +1,9 @@ | |||
| # Local tooling and generated runtime files | |||
| /.agents/ | |||
| /.github/ | |||
| /_bmad/ | |||
| /_bmad*/ | |||
| /logs/ | |||
| *.log | |||
| *.user | |||
| *.suo | |||
| @@ -0,0 +1,134 @@ | |||
| # PostcardMojo Agent Instructions | |||
| ## Role | |||
| Act as an expert web developer, marketing strategist, and Classic ASP specialist. | |||
| Build websites and features that are: | |||
| - modern, polished, and visually credible | |||
| - easy to understand and use | |||
| - responsive across desktop, tablet, and mobile devices | |||
| - accessible and keyboard-friendly | |||
| - fast, secure, and maintainable | |||
| - written with clear marketing goals and useful calls to action | |||
| - appropriate for the PostcardMojo brand and its intended audience | |||
| Combine sound engineering with strong user-experience and marketing judgment. | |||
| Do not focus on appearance alone. Consider clarity, trust, conversion, content | |||
| hierarchy, accessibility, performance, and the complete customer journey. | |||
| ## Technology | |||
| This is a Classic ASP application using VBScript and the existing MVC | |||
| framework in this repository. | |||
| Use the existing framework, its conventions, and its utilities to implement | |||
| all application features. Prefer the established project structure: | |||
| - `public/` for the web entry point and public assets | |||
| - `app/controllers/` for request handling | |||
| - `app/views/` for presentation | |||
| - `app/models/` for application and domain data | |||
| - `app/services/` for business logic | |||
| - `app/repositories/` for persistence logic | |||
| - `db/migrations/` for database changes | |||
| - `core/` for the existing framework implementation | |||
| Keep controllers thin. Keep business logic out of views. Keep database access | |||
| inside repositories and use parameterized queries for all untrusted values. | |||
| Encode dynamic HTML output and validate all request data on the server. | |||
| ## Framework Boundary | |||
| Use the framework as it currently exists to complete work whenever reasonably | |||
| possible. Do not bypass, replace, or duplicate framework behavior with an | |||
| unrelated implementation. | |||
| Treat `core/` as protected framework code. Do not modify, extend, replace, or | |||
| add framework code without the user's explicit approval. | |||
| If a requested feature cannot be implemented correctly with the existing | |||
| framework: | |||
| 1. Explain what capability is missing. | |||
| 2. Describe the effect on the requested feature. | |||
| 3. Propose the smallest practical framework change or addition. | |||
| 4. Identify the files that would be affected and any important risks or | |||
| tradeoffs. | |||
| 5. Ask the user for permission before changing framework code. | |||
| Do not treat silence as permission. Until approval is given, continue only | |||
| with work that does not require a framework change. | |||
| Changes to application code outside `core/` do not require separate permission | |||
| when they are a normal part of the user's requested feature. | |||
| ## Required Code Generators | |||
| Create all new controllers, database migrations, models, and repositories with | |||
| the existing generator scripts in `scripts/`. Do not create these files from | |||
| scratch or substitute a separate scaffolding process. | |||
| Use the appropriate project script: | |||
| - `scripts/generateController.vbs` for controllers | |||
| - `scripts/generateMigration.vbs` for database migrations | |||
| - `scripts/GenerateRepo.vbs` for models and repositories | |||
| After generation, move generated files into the appropriate application | |||
| folder, then complete the normal framework wiring. This includes controller | |||
| autoloading, controller registration, route definitions, and any required | |||
| view or service integration. | |||
| Generated code may be edited after creation to implement the requested feature, | |||
| but its initial structure must come from the relevant script. | |||
| If a generator is missing, fails, or cannot express a required structure: | |||
| 1. Stop before manually creating the affected controller, migration, model, or | |||
| repository. | |||
| 2. Explain the generator limitation or failure. | |||
| 3. Recommend the smallest practical solution. | |||
| 4. Ask the user for permission before manually creating the file or changing | |||
| the generator/framework. | |||
| ## Working Standards | |||
| Before implementing a feature: | |||
| 1. Inspect the relevant framework and application code. | |||
| 2. Reuse existing helpers and patterns before creating new ones. | |||
| 3. Confirm that the planned work stays outside protected framework code. | |||
| 4. Consider usability, accessibility, responsive behavior, security, SEO, and | |||
| the feature's marketing purpose. | |||
| When implementing: | |||
| - follow existing Classic ASP and VBScript conventions | |||
| - use explicit, descriptive names | |||
| - keep components focused and understandable | |||
| - preserve established routes and behavior unless a change is requested | |||
| - avoid unnecessary dependencies and external libraries | |||
| - never commit credentials, secrets, or environment-specific private data | |||
| - make application-level changes narrowly and deliberately | |||
| After implementing: | |||
| - inspect all changed ASP and VBScript for syntax and include-path errors | |||
| - verify controller registration and route wiring | |||
| - test the affected pages through IIS or IIS Express when available | |||
| - check responsive and accessible behavior for user-facing work | |||
| - report what changed, what was verified, and any remaining limitations | |||
| ## Decision Priority | |||
| When making implementation decisions, prioritize: | |||
| 1. the user's explicit request | |||
| 2. security and data integrity | |||
| 3. the protected framework boundary | |||
| 4. usability and accessibility | |||
| 5. marketing effectiveness and brand clarity | |||
| 6. maintainability and consistency with the existing application | |||
| @@ -0,0 +1 @@ | |||
| @AGENTS.md | |||
| @@ -0,0 +1,35 @@ | |||
| # PostcardMojo | |||
| A clean Classic ASP application scaffold based on the RouteKit MVC framework. | |||
| ## Run locally | |||
| 1. Install IIS Express with Classic ASP enabled. | |||
| 2. Run `run_site.cmd`. | |||
| 3. Browse to `http://localhost:8080/`. | |||
| The landing page is served by `HomeController.Index` through | |||
| `app/views/Home/landing.asp`. The earlier logo-reference page remains at | |||
| `app/views/Home/index.asp`. Requests enter through `public/Default.asp`. | |||
| ## Add an MVC feature | |||
| 1. Generate a controller: | |||
| `cscript //nologo scripts\generateController.vbs ExampleController "Index"` | |||
| 2. Put the controller in `app/controllers/` and include it from | |||
| `app/controllers/autoload_controllers.asp`. | |||
| 3. Register its name in `core/lib.ControllerRegistry.asp`. | |||
| 4. Add its route in `public/Default.asp`. | |||
| 5. Add any view files under `app/views/`. | |||
| Optional generators are also provided for database migrations and repository | |||
| classes. Configure the connection string in `public/web.config` only when the | |||
| application needs a database. | |||
| ## Structure | |||
| - `public/` — IIS site root and static assets | |||
| - `core/` — reusable MVC framework | |||
| - `app/` — application controllers, views, models, and repositories | |||
| - `db/migrations/` — application database migrations | |||
| - `scripts/` — generators and deployment utilities | |||
| @@ -0,0 +1,26 @@ | |||
| <% | |||
| Class HomeController_Class | |||
| Public Title | |||
| Public useLayout | |||
| Private Sub Class_Initialize() | |||
| Title = "PostcardMojo Logo Files" | |||
| useLayout = False | |||
| End Sub | |||
| Public Sub Index() | |||
| %> | |||
| <!--#include file="../views/Home/landing.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 | |||
| %> | |||
| @@ -0,0 +1 @@ | |||
| <!--#include file="HomeController.asp" --> | |||
| @@ -0,0 +1,263 @@ | |||
| <title>PostcardMojo Logo Files</title> | |||
| <meta name="claude:viewport-fit-sides" content="cover"> | |||
| <link rel="stylesheet" href="https://fonts.googleapis.com/css2?family=Fredoka:wght@500;600&family=Figtree:wght@400;500;600&family=JetBrains+Mono:wght@400;500&display=swap"> | |||
| <style> | |||
| /* Layout: brand header, sticky-free control bar, then one comparison row per logo: PNG panel | JPG panel, stacking on narrow screens */ | |||
| :root { | |||
| --bg: #f6f5f1; | |||
| --surface: #ffffff; | |||
| --fg: #1a2a3a; | |||
| --muted: #5f6b76; | |||
| --line: #e2dfd6; | |||
| --navy: #1b3a57; | |||
| --gold: #b88a1c; | |||
| --good-bg: #e6f2ea; | |||
| --good-fg: #1f6b3a; | |||
| --warn-bg: #fdeeea; | |||
| --warn-fg: #a3341c; | |||
| --swatch-light: #ffffff; | |||
| --swatch-dark: #172a3d; | |||
| --check-a: #ffffff; | |||
| --check-b: #e8e6e0; | |||
| --focus: #b88a1c; | |||
| --font-display: "Fredoka", "Nunito", system-ui, sans-serif; | |||
| --font-body: "Figtree", system-ui, -apple-system, "Segoe UI", sans-serif; | |||
| --font-mono: "JetBrains Mono", ui-monospace, Consolas, monospace; | |||
| } | |||
| @media (prefers-color-scheme: dark) { | |||
| :root:not([data-theme="light"]) { | |||
| --bg: #11161c; --surface: #19212a; --fg: #e8ecef; --muted: #9aa6b1; --line: #2a3542; | |||
| --navy: #9cc0e2; --gold: #e2bb55; --good-bg: #17301f; --good-fg: #8fd3a5; | |||
| --warn-bg: #3a1f19; --warn-fg: #f4a48f; | |||
| --check-a: #2a3440; --check-b: #222b35; --focus: #e2bb55; color-scheme: dark; | |||
| } | |||
| } | |||
| :root[data-theme="dark"] { | |||
| --bg: #11161c; --surface: #19212a; --fg: #e8ecef; --muted: #9aa6b1; --line: #2a3542; | |||
| --navy: #9cc0e2; --gold: #e2bb55; --good-bg: #17301f; --good-fg: #8fd3a5; | |||
| --warn-bg: #3a1f19; --warn-fg: #f4a48f; | |||
| --check-a: #2a3440; --check-b: #222b35; --focus: #e2bb55; color-scheme: dark; | |||
| } | |||
| body { | |||
| background: var(--bg); color: var(--fg); font-family: var(--font-body); font-size: 15px; line-height: 1.5; | |||
| padding-left: max(16px, env(safe-area-inset-left, 0px)); | |||
| padding-right: max(16px, env(safe-area-inset-right, 0px)); | |||
| padding-block: 40px 64px; | |||
| } | |||
| .wrap { max-width: 1180px; margin: 0 auto; display: grid; gap: 32px; } | |||
| header { display: grid; gap: 8px; } | |||
| h1 { font-family: var(--font-display); font-weight: 600; font-size: 2rem; line-height: 1.15; margin: 0; text-wrap: balance; color: var(--navy); } | |||
| h1 span { color: var(--gold); } | |||
| .lede { margin: 0; color: var(--muted); max-width: 66ch; } | |||
| .totals { display: flex; flex-wrap: wrap; gap: 8px 20px; font-size: 0.875rem; color: var(--muted); } | |||
| .totals b { color: var(--fg); font-family: var(--font-mono); font-weight: 500; font-variant-numeric: tabular-nums; } | |||
| .controls { display: flex; flex-wrap: wrap; align-items: center; gap: 12px 24px; } | |||
| .ctl { display: flex; align-items: center; gap: 10px; } | |||
| .ctl .label { font-size: 0.75rem; letter-spacing: 0.08em; text-transform: uppercase; color: var(--muted); font-weight: 600; } | |||
| .seg { display: inline-flex; border: 1px solid var(--line); border-radius: 999px; padding: 3px; background: var(--surface); } | |||
| .seg button { | |||
| font: inherit; font-size: 0.875rem; font-weight: 500; border: 0; background: transparent; color: var(--muted); | |||
| padding: 6px 14px; border-radius: 999px; cursor: pointer; | |||
| } | |||
| .seg button[aria-pressed="true"] { background: var(--navy); color: var(--bg); } | |||
| button:focus-visible, .panel .view:focus-visible { outline: 2px solid var(--focus); outline-offset: 2px; } | |||
| section { display: grid; gap: 14px; } | |||
| h2 { font-family: var(--font-display); font-weight: 500; font-size: 1.25rem; margin: 0; } | |||
| h2 small { font-family: var(--font-body); font-size: 0.875rem; color: var(--muted); font-weight: 400; margin-left: 6px; } | |||
| .list { display: grid; gap: 16px; } | |||
| .list.icons { grid-template-columns: repeat(auto-fill, minmax(min(100%, 520px), 1fr)); } | |||
| .item { background: var(--surface); border: 1px solid var(--line); border-radius: 10px; overflow: hidden; display: grid; min-width: 0; } | |||
| .item-head { display: flex; flex-wrap: wrap; align-items: baseline; gap: 4px 12px; padding: 12px 14px; border-bottom: 1px solid var(--line); } | |||
| .name { font-family: var(--font-mono); font-size: 0.875rem; font-weight: 500; overflow-wrap: anywhere; } | |||
| .dims { font-family: var(--font-mono); font-size: 0.8125rem; color: var(--muted); font-variant-numeric: tabular-nums; } | |||
| .pill { font-size: 0.6875rem; font-weight: 600; letter-spacing: 0.06em; text-transform: uppercase; padding: 2px 8px; border-radius: 999px; } | |||
| .pill.warn { background: var(--warn-bg); color: var(--warn-fg); } | |||
| .pill.good { background: var(--good-bg); color: var(--good-fg); } | |||
| .compare { display: grid; grid-template-columns: 1fr 1fr; } | |||
| .item.wide .compare { grid-template-columns: 1fr; } | |||
| @media (max-width: 640px) { .compare { grid-template-columns: 1fr; } } | |||
| .panel { display: grid; grid-template-rows: auto 1fr; min-width: 0; } | |||
| .panel + .panel { border-left: 1px solid var(--line); } | |||
| .item.wide .panel + .panel { border-left: 0; border-top: 1px solid var(--line); } | |||
| @media (max-width: 640px) { .panel + .panel { border-left: 0; border-top: 1px solid var(--line); } } | |||
| .panel-label { display: flex; justify-content: space-between; gap: 8px; padding: 8px 14px; font-size: 0.8125rem; color: var(--muted); } | |||
| .panel-label .fmt { font-weight: 600; color: var(--fg); letter-spacing: 0.04em; } | |||
| .panel-label .kb { font-family: var(--font-mono); font-variant-numeric: tabular-nums; } | |||
| .view { overflow: auto; padding: 24px 20px; display: grid; place-items: center; min-height: 140px; } | |||
| .view img { display: block; max-width: none; height: auto; } | |||
| body[data-zoom="1"] .view img { max-width: 100%; } | |||
| body:not([data-zoom="1"]) .view { place-items: start; } | |||
| body:not([data-zoom="1"]) .view img { image-rendering: pixelated; } | |||
| body[data-bg="light"] .view { background: var(--swatch-light); } | |||
| body[data-bg="dark"] .view { background: var(--swatch-dark); } | |||
| body[data-bg="checker"] .view { | |||
| background-color: var(--check-a); | |||
| background-image: linear-gradient(45deg, var(--check-b) 25%, transparent 25%, transparent 75%, var(--check-b) 75%), | |||
| linear-gradient(45deg, var(--check-b) 25%, transparent 25%, transparent 75%, var(--check-b) 75%); | |||
| background-size: 16px 16px; background-position: 0 0, 8px 8px; | |||
| } | |||
| footer { color: var(--muted); font-size: 0.8125rem; border-top: 1px solid var(--line); padding-top: 16px; display: grid; gap: 6px; } | |||
| footer p { margin: 0; max-width: 80ch; } | |||
| code { font-family: var(--font-mono); font-size: 0.92em; } | |||
| </style> | |||
| <div class="wrap"> | |||
| <header> | |||
| <h1>postcard<span>mojo</span> logo files</h1> | |||
| <p class="lede">Each logo as a transparent PNG (left) and a white-background JPG (right). Zoom in to look for compression artifacts. Switch to a dark background to see where the JPG's white box shows.</p> | |||
| <div class="totals" id="totals"></div> | |||
| </header> | |||
| <div class="controls"> | |||
| <div class="ctl" role="group" aria-label="Preview background"> | |||
| <span class="label">Background</span> | |||
| <div class="seg" id="bg-seg"> | |||
| <button type="button" id="bg-light" data-bg="light" aria-pressed="true">Light</button> | |||
| <button type="button" id="bg-dark" data-bg="dark" aria-pressed="false">Dark</button> | |||
| <button type="button" id="bg-checker" data-bg="checker" aria-pressed="false">Transparent</button> | |||
| </div> | |||
| </div> | |||
| <div class="ctl" role="group" aria-label="Zoom"> | |||
| <span class="label">Zoom</span> | |||
| <div class="seg" id="zoom-seg"> | |||
| <button type="button" id="zoom-1" data-zoom="1" aria-pressed="true">Fit</button> | |||
| <button type="button" id="zoom-2" data-zoom="2" aria-pressed="false">2×</button> | |||
| <button type="button" id="zoom-4" data-zoom="4" aria-pressed="false">4×</button> | |||
| </div> | |||
| </div> | |||
| </div> | |||
| <section> | |||
| <h2>Full logo <small>card icon with wordmark</small></h2> | |||
| <div class="list" id="lockups"></div> | |||
| </section> | |||
| <section> | |||
| <h2>Icon <small>postcard mark only</small></h2> | |||
| <div class="list icons" id="icons"></div> | |||
| </section> | |||
| <footer> | |||
| <p>PNGs are in <code>images/logos/png/</code> and JPGs in <code>images/logos/jpg/</code>. Sizes are the actual pixel size of each file. The names come from the labels on the original sheet, which don't match the real sizes.</p> | |||
| <p>At 2× and 4×, scrolling one panel scrolls its partner too, so both show the same spot.</p> | |||
| </footer> | |||
| </div> | |||
| <script> | |||
| (function () { | |||
| // w, h = pixels; png, jpg = file size in KB | |||
| var lockups = [ | |||
| { file: 'logo_full_large', w: 796, h: 220, png: 216.4, jpg: 26.7, wide: true }, | |||
| { file: 'logo_full_medium_c', w: 411, h: 123, png: 68.8, jpg: 12.9 }, | |||
| { file: 'logo_full_medium_a', w: 285, h: 88, png: 38.0, jpg: 7.2 }, | |||
| { file: 'logo_full_small_b', w: 217, h: 73, png: 24.0, jpg: 4.8 }, | |||
| { file: 'logo_full_small_a', w: 187, h: 63, png: 18.7, jpg: 3.9 }, | |||
| { file: 'logo_full_medium_b_misprint', w: 535, h: 129, png: 96.1, jpg: 17.7, misprint: true } | |||
| ]; | |||
| var icons = [ | |||
| { file: 'icon_256', w: 169, h: 129, png: 41.2, jpg: 6.7 }, | |||
| { file: 'icon_64', w: 143, h: 85, png: 21.5, jpg: 4.0 }, | |||
| { file: 'icon_24', w: 95, h: 81, png: 14.1, jpg: 3.8 }, | |||
| { file: 'icon_small_8', w: 90, h: 72, png: 13.9, jpg: 3.0 } | |||
| ]; | |||
| function el(tag, cls, text) { | |||
| var e = document.createElement(tag); | |||
| if (cls) e.className = cls; | |||
| if (text != null) e.textContent = text; | |||
| return e; | |||
| } | |||
| function panel(fmt, src, kb, item) { | |||
| var p = el('div', 'panel'); | |||
| var label = el('div', 'panel-label'); | |||
| label.append(el('span', 'fmt', fmt), el('span', 'kb', kb.toFixed(1) + ' KB')); | |||
| var view = el('div', 'view'); | |||
| view.tabIndex = 0; | |||
| view.setAttribute('aria-label', fmt + ' preview of ' + item.file); | |||
| var img = el('img'); | |||
| img.src = src; img.alt = item.file + ' as ' + fmt; | |||
| img.width = item.w; img.height = item.h; | |||
| img.dataset.w = item.w; | |||
| view.append(img); | |||
| p.append(label, view); | |||
| return p; | |||
| } | |||
| function render(list, target) { | |||
| list.forEach(function (item) { | |||
| var card = el('article', 'item' + (item.wide ? ' wide' : '')); | |||
| var head = el('div', 'item-head'); | |||
| head.append(el('span', 'name', item.file), el('span', 'dims', item.w + ' × ' + item.h)); | |||
| var saved = Math.round((1 - item.jpg / item.png) * 100); | |||
| head.append(el('span', 'pill good', 'JPG ' + saved + '% smaller')); | |||
| if (item.misprint) head.append(el('span', 'pill warn', 'Do not use: reads "pomostcard"')); | |||
| var cmp = el('div', 'compare'); | |||
| var a = panel('PNG', 'images/logos/png/' + item.file + '.png', item.png, item); | |||
| var b = panel('JPG', 'images/logos/jpg/' + item.file + '.jpg', item.jpg, item); | |||
| cmp.append(a, b); | |||
| linkScroll(a.querySelector('.view'), b.querySelector('.view')); | |||
| card.append(head, cmp); | |||
| target.append(card); | |||
| }); | |||
| } | |||
| function linkScroll(x, y) { | |||
| var lock = false; | |||
| function sync(from, to) { | |||
| from.addEventListener('scroll', function () { | |||
| if (lock) return; | |||
| lock = true; | |||
| to.scrollLeft = from.scrollLeft; to.scrollTop = from.scrollTop; | |||
| requestAnimationFrame(function () { lock = false; }); | |||
| }); | |||
| } | |||
| sync(x, y); sync(y, x); | |||
| } | |||
| render(lockups, document.getElementById('lockups')); | |||
| render(icons, document.getElementById('icons')); | |||
| var all = lockups.concat(icons); | |||
| var pngTotal = all.reduce(function (s, i) { return s + i.png; }, 0); | |||
| var jpgTotal = all.reduce(function (s, i) { return s + i.jpg; }, 0); | |||
| var totals = document.getElementById('totals'); | |||
| totals.innerHTML = ''; | |||
| [['All PNGs', pngTotal.toFixed(0) + ' KB'], ['All JPGs', jpgTotal.toFixed(0) + ' KB'], | |||
| ['Saved', Math.round((1 - jpgTotal / pngTotal) * 100) + '%']].forEach(function (t) { | |||
| var s = el('span', null, t[0] + ' '); | |||
| s.append(el('b', null, t[1])); | |||
| totals.append(s); | |||
| }); | |||
| function setBg(bg) { | |||
| document.body.setAttribute('data-bg', bg); | |||
| document.querySelectorAll('#bg-seg button').forEach(function (b) { b.setAttribute('aria-pressed', String(b.dataset.bg === bg)); }); | |||
| try { localStorage.setItem('logo-bg', bg); } catch (e) {} | |||
| } | |||
| function setZoom(z) { | |||
| document.body.setAttribute('data-zoom', z); | |||
| document.querySelectorAll('#zoom-seg button').forEach(function (b) { b.setAttribute('aria-pressed', String(b.dataset.zoom === z)); }); | |||
| document.querySelectorAll('.view img').forEach(function (img) { img.style.width = (img.dataset.w * Number(z)) + 'px'; }); | |||
| if (z === '1') document.querySelectorAll('.view img').forEach(function (img) { img.style.width = ''; }); | |||
| try { localStorage.setItem('logo-zoom', z); } catch (e) {} | |||
| } | |||
| document.querySelectorAll('#bg-seg button').forEach(function (b) { b.addEventListener('click', function () { setBg(b.dataset.bg); }); }); | |||
| document.querySelectorAll('#zoom-seg button').forEach(function (b) { b.addEventListener('click', function () { setZoom(b.dataset.zoom); }); }); | |||
| var savedBg = 'light', savedZoom = '1'; | |||
| try { savedBg = localStorage.getItem('logo-bg') || 'light'; savedZoom = localStorage.getItem('logo-zoom') || '1'; } catch (e) {} | |||
| setBg(savedBg); | |||
| setZoom(savedZoom); | |||
| })(); | |||
| </script> | |||
| @@ -0,0 +1,276 @@ | |||
| <% | |||
| Response.Charset = "utf-8" | |||
| Response.CodePage = 65001 | |||
| %> | |||
| <!doctype html> | |||
| <html lang="en"> | |||
| <head> | |||
| <meta charset="utf-8"> | |||
| <meta name="viewport" content="width=device-width, initial-scale=1"> | |||
| <title>PostcardMojo | Big Local Reach on One 9×12 Postcard</title> | |||
| <meta name="description" content="Put your business on an oversized 9×12 postcard shared by a curated group of local businesses and delivered directly to nearby mailboxes."> | |||
| <meta name="theme-color" content="#062f4f"> | |||
| <link rel="icon" type="image/jpeg" href="/images/logos/sharp/jpg/icon_64.jpg"> | |||
| <link rel="preconnect" href="https://fonts.googleapis.com"> | |||
| <link rel="preconnect" href="https://fonts.gstatic.com" crossorigin> | |||
| <link href="https://fonts.googleapis.com/css2?family=DM+Sans:wght@400;500;600;700&family=Manrope:wght@600;700;800&display=swap" rel="stylesheet"> | |||
| <link rel="stylesheet" href="/css/home.css"> | |||
| </head> | |||
| <body id="top"> | |||
| <a class="skip-link" href="#main-content">Skip to main content</a> | |||
| <header class="site-header"> | |||
| <div class="shell nav-shell"> | |||
| <a class="brand" href="/" aria-label="PostcardMojo home"> | |||
| <img src="/images/logos/sharp/jpg/logo_full_small_b.jpg" width="217" height="73" alt="PostcardMojo"> | |||
| </a> | |||
| <nav class="site-nav" aria-label="Primary navigation"> | |||
| <a href="#how-it-works">How it works</a> | |||
| <a href="#why-postcards">Why it works</a> | |||
| <a href="#good-fit">Who it is for</a> | |||
| <a href="#faq">FAQ</a> | |||
| </nav> | |||
| <a class="button button-small button-primary" href="#get-started">Find your spot</a> | |||
| </div> | |||
| </header> | |||
| <main id="main-content"> | |||
| <section class="hero"> | |||
| <div class="hero-glow hero-glow-one" aria-hidden="true"></div> | |||
| <div class="hero-glow hero-glow-two" aria-hidden="true"></div> | |||
| <div class="shell hero-grid"> | |||
| <div class="hero-copy"> | |||
| <p class="eyebrow"><span></span> Shared direct mail for local businesses</p> | |||
| <h1>Make your business <em>impossible to miss</em> in the mailbox.</h1> | |||
| <p class="hero-lede">PostcardMojo puts a curated lineup of local businesses on one oversized 9×12 postcard. Your offer gets a bold, tangible place in nearby homes while participating businesses share the cost of printing and postage.</p> | |||
| <div class="hero-actions"> | |||
| <a class="button button-primary" href="#get-started">Explore a campaign</a> | |||
| <a class="button button-quiet" href="#how-it-works">See how it works <span aria-hidden="true">→</span></a> | |||
| </div> | |||
| <ul class="hero-points" aria-label="Campaign highlights"> | |||
| <li><span aria-hidden="true">✓</span> Oversized 9×12 format</li> | |||
| <li><span aria-hidden="true">✓</span> Built for neighborhood reach</li> | |||
| <li><span aria-hidden="true">✓</span> Shared production costs</li> | |||
| </ul> | |||
| </div> | |||
| <div class="postcard-stage" aria-label="Illustration of a shared 9 by 12 postcard"> | |||
| <div class="postcard-shadow" aria-hidden="true"></div> | |||
| <div class="postcard"> | |||
| <div class="postcard-topline"> | |||
| <span>THE LOCAL EDITION</span> | |||
| <span>9 × 12</span> | |||
| </div> | |||
| <div class="postcard-feature"> | |||
| <img src="/images/logos/sharp/jpg/logo_full_small_a.jpg" width="187" height="63" alt=""> | |||
| <strong>Big local offers.<br>One memorable mailer.</strong> | |||
| </div> | |||
| <div class="ad-grid" aria-hidden="true"> | |||
| <div class="ad-tile tile-gold"><span>HOME</span><strong>Freshen up your space</strong></div> | |||
| <div class="ad-tile tile-navy"><span>DINING</span><strong>A local favorite</strong></div> | |||
| <div class="ad-tile tile-cream"><span>WELLNESS</span><strong>Feel your best</strong></div> | |||
| <div class="ad-tile tile-coral"><span>SERVICES</span><strong>Help is nearby</strong></div> | |||
| <div class="ad-tile tile-blue"><span>AUTO</span><strong>Keep moving</strong></div> | |||
| <div class="ad-tile tile-white"><span>YOUR BUSINESS</span><strong>belongs here</strong></div> | |||
| </div> | |||
| <div class="postcard-edge">A collection of businesses worth knowing</div> | |||
| </div> | |||
| <div class="stage-note"><span aria-hidden="true">↗</span> One card. Multiple businesses. A whole neighborhood of opportunity.</div> | |||
| </div> | |||
| </div> | |||
| </section> | |||
| <section class="signal-strip" aria-label="What makes PostcardMojo different"> | |||
| <div class="shell signal-grid"> | |||
| <div><strong>9 × 12</strong><span>Oversized presence</span></div> | |||
| <div><strong>One card</strong><span>A curated local lineup</span></div> | |||
| <div><strong>Shared</strong><span>Print and postage costs</span></div> | |||
| <div><strong>Local</strong><span>Campaign-focused reach</span></div> | |||
| </div> | |||
| </section> | |||
| <section class="section section-light" id="how-it-works"> | |||
| <div class="shell"> | |||
| <div class="section-heading heading-centered"> | |||
| <p class="eyebrow eyebrow-centered"><span></span> Simple by design</p> | |||
| <h2>From your offer to their mailbox.</h2> | |||
| <p>PostcardMojo turns a group of complementary local businesses into one well-organized, high-visibility mail piece.</p> | |||
| </div> | |||
| <ol class="steps"> | |||
| <li> | |||
| <span class="step-number">01</span> | |||
| <div class="step-icon" aria-hidden="true">◎</div> | |||
| <h3>Choose your campaign</h3> | |||
| <p>Start with the local area and timing that fit your business goals.</p> | |||
| </li> | |||
| <li> | |||
| <span class="step-number">02</span> | |||
| <div class="step-icon" aria-hidden="true">◇</div> | |||
| <h3>Claim your category</h3> | |||
| <p>Reserve a space for your type of business, subject to campaign availability.</p> | |||
| </li> | |||
| <li> | |||
| <span class="step-number">03</span> | |||
| <div class="step-icon" aria-hidden="true">✦</div> | |||
| <h3>Shape the offer</h3> | |||
| <p>Bring your logo, message, and promotion together in a clear, focused ad.</p> | |||
| </li> | |||
| <li> | |||
| <span class="step-number">04</span> | |||
| <div class="step-icon" aria-hidden="true">↗</div> | |||
| <h3>Reach the mailbox</h3> | |||
| <p>The finished postcard is printed and mailed as one coordinated campaign.</p> | |||
| </li> | |||
| </ol> | |||
| </div> | |||
| </section> | |||
| <section class="section section-navy" id="why-postcards"> | |||
| <div class="shell value-grid"> | |||
| <div class="value-copy"> | |||
| <p class="eyebrow eyebrow-on-dark"><span></span> A physical advantage</p> | |||
| <h2>Digital ads disappear with a swipe. A great postcard gets held.</h2> | |||
| <p>PostcardMojo gives your business a physical moment with a local customer. The oversized format creates room for a useful offer, recognizable branding, and a direct next step.</p> | |||
| <a class="text-link" href="#get-started">Put your offer on the next card <span aria-hidden="true">→</span></a> | |||
| </div> | |||
| <div class="benefit-list"> | |||
| <article> | |||
| <span class="benefit-mark">01</span> | |||
| <div><h3>Big enough to notice</h3><p>A 9×12 card has the visual presence to stand apart from ordinary envelopes and smaller mail pieces.</p></div> | |||
| </article> | |||
| <article> | |||
| <span class="benefit-mark">02</span> | |||
| <div><h3>Local enough to matter</h3><p>Campaigns can be centered on the communities where participating businesses want to be known.</p></div> | |||
| </article> | |||
| <article> | |||
| <span class="benefit-mark">03</span> | |||
| <div><h3>Shared without feeling small</h3><p>Businesses share the mail piece while each ad keeps its own message, offer, and brand identity.</p></div> | |||
| </article> | |||
| <article> | |||
| <span class="benefit-mark">04</span> | |||
| <div><h3>Easy to act on</h3><p>A phone number, URL, QR code, or offer gives recipients a simple way to take the next step.</p></div> | |||
| </article> | |||
| </div> | |||
| </div> | |||
| </section> | |||
| <section class="section section-warm" id="good-fit"> | |||
| <div class="shell"> | |||
| <div class="section-heading heading-split"> | |||
| <div> | |||
| <p class="eyebrow"><span></span> Made for the neighborhood</p> | |||
| <h2>Local businesses belong in local mailboxes.</h2> | |||
| </div> | |||
| <p>If nearby households can become customers, a PostcardMojo campaign can help introduce your business and give them a reason to respond.</p> | |||
| </div> | |||
| <div class="fit-grid"> | |||
| <article class="fit-card"> | |||
| <span class="fit-icon" aria-hidden="true">⌂</span> | |||
| <h3>Home services</h3> | |||
| <p>Landscaping, cleaning, roofing, HVAC, plumbing, remodeling, and other trusted pros.</p> | |||
| </article> | |||
| <article class="fit-card"> | |||
| <span class="fit-icon" aria-hidden="true">+</span> | |||
| <h3>Health & wellness</h3> | |||
| <p>Dentists, chiropractors, fitness studios, salons, spas, and wellness providers.</p> | |||
| </article> | |||
| <article class="fit-card"> | |||
| <span class="fit-icon" aria-hidden="true">♨</span> | |||
| <h3>Food & experiences</h3> | |||
| <p>Restaurants, cafés, entertainment, family activities, and places worth discovering.</p> | |||
| </article> | |||
| <article class="fit-card"> | |||
| <span class="fit-icon" aria-hidden="true">◆</span> | |||
| <h3>Professional services</h3> | |||
| <p>Real estate, insurance, financial, legal, pet care, automotive, and local experts.</p> | |||
| </article> | |||
| </div> | |||
| </div> | |||
| </section> | |||
| <section class="section offer-section"> | |||
| <div class="shell offer-grid"> | |||
| <div class="offer-card" aria-hidden="true"> | |||
| <div class="offer-stamp">YOUR<br>OFFER</div> | |||
| <p class="offer-kicker">LOCAL FAVORITE</p> | |||
| <p class="offer-headline">Give neighbors a reason to try you.</p> | |||
| <div class="offer-coupon"><strong>20% OFF</strong><span>your first visit</span></div> | |||
| <div class="offer-url">YOURBUSINESS.COM</div> | |||
| </div> | |||
| <div class="offer-copy"> | |||
| <p class="eyebrow"><span></span> Make the space count</p> | |||
| <h2>A clear offer turns attention into action.</h2> | |||
| <p>Your ad does not need to tell your whole story. It needs to make one strong promise and give a nearby customer one easy next step.</p> | |||
| <ul class="check-list"> | |||
| <li><span>✓</span><div><strong>A direct headline</strong><small>Say what you do and why it matters.</small></div></li> | |||
| <li><span>✓</span><div><strong>A compelling reason to respond</strong><small>Feature an offer, service, or timely benefit.</small></div></li> | |||
| <li><span>✓</span><div><strong>A simple call to action</strong><small>Use a memorable URL, phone number, or QR code.</small></div></li> | |||
| </ul> | |||
| </div> | |||
| </div> | |||
| </section> | |||
| <section class="section section-light" id="faq"> | |||
| <div class="shell faq-grid"> | |||
| <div class="faq-intro"> | |||
| <p class="eyebrow"><span></span> The short version</p> | |||
| <h2>Questions before you join the card?</h2> | |||
| <p>Every campaign is shaped around its participating businesses and selected local area. These answers cover the basics.</p> | |||
| </div> | |||
| <div class="faq-list"> | |||
| <details open> | |||
| <summary>What is a shared 9×12 postcard?<span aria-hidden="true">+</span></summary> | |||
| <p>It is one oversized mail piece featuring a curated collection of local business ads. The format gives recipients multiple useful offers while advertisers share print and mailing costs.</p> | |||
| </details> | |||
| <details> | |||
| <summary>Will a direct competitor appear beside me?<span aria-hidden="true">+</span></summary> | |||
| <p>Category availability is managed by campaign. Ask about category placement and any available exclusivity when reserving your space.</p> | |||
| </details> | |||
| <details> | |||
| <summary>Do I need a finished ad?<span aria-hidden="true">+</span></summary> | |||
| <p>Start with your logo, offer, contact details, and any brand assets you already have. Creative requirements and available assistance can be confirmed for your campaign.</p> | |||
| </details> | |||
| <details> | |||
| <summary>Where will the postcard be mailed?<span aria-hidden="true">+</span></summary> | |||
| <p>Campaigns are planned around selected local areas. Exact geography, timing, and mailing details are confirmed before you reserve a spot.</p> | |||
| </details> | |||
| <details> | |||
| <summary>What does a campaign cost?<span aria-hidden="true">+</span></summary> | |||
| <p>Pricing depends on the campaign, placement, and mailing plan. Request current details for the area you want to reach.</p> | |||
| </details> | |||
| </div> | |||
| </div> | |||
| </section> | |||
| <section class="cta-section" id="get-started"> | |||
| <div class="shell cta-card"> | |||
| <div class="cta-rings" aria-hidden="true"></div> | |||
| <div> | |||
| <p class="eyebrow eyebrow-on-dark"><span></span> Your neighborhood is waiting</p> | |||
| <h2>Put your business in the next mailbox moment.</h2> | |||
| <p>Tell us what you do and where you want to be seen. We will help you explore the right PostcardMojo campaign.</p> | |||
| </div> | |||
| <div class="cta-actions"> | |||
| <a class="button button-gold" href="mailto:info@postcardmojo.com?subject=PostcardMojo%209x12%20campaign%20inquiry">Request campaign details</a> | |||
| <span>Campaign availability varies by area.</span> | |||
| </div> | |||
| </div> | |||
| </section> | |||
| </main> | |||
| <footer class="site-footer"> | |||
| <div class="shell footer-grid"> | |||
| <a class="footer-brand" href="#top" aria-label="Back to top"> | |||
| <img src="/images/logos/sharp/jpg/logo_full_small_a.jpg" width="187" height="63" alt="PostcardMojo"> | |||
| </a> | |||
| <p>Big local visibility, delivered.</p> | |||
| <nav aria-label="Footer navigation"> | |||
| <a href="#how-it-works">How it works</a> | |||
| <a href="#faq">FAQ</a> | |||
| <a href="mailto:info@postcardmojo.com">Contact</a> | |||
| </nav> | |||
| <small>© <%= Year(Date()) %> PostcardMojo. All rights reserved.</small> | |||
| </div> | |||
| </footer> | |||
| </body> | |||
| </html> | |||
| @@ -0,0 +1 @@ | |||
| <% ' Optional shared layout footer. %> | |||
| @@ -0,0 +1 @@ | |||
| <% ' Optional shared layout header. %> | |||
| @@ -0,0 +1,23 @@ | |||
| <!--#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"--> | |||
| <!--#include file="../Core/lib.ad.auth.asp"--> | |||
| <!--#include file="../Core/databaseConnection.asp"--> | |||
| @@ -0,0 +1,127 @@ | |||
| <% | |||
| '------------------------------------------------------------------------------ | |||
| ' DatabaseConnection.Class.inc | |||
| ' A singleton VBScript "factory" for ADODB.Connection to multiple databases | |||
| ' Enhanced with separate error handling for creation and open operations | |||
| '------------------------------------------------------------------------------ | |||
| ' Singleton holder | |||
| Dim DatabaseConnection__Singleton | |||
| Set DatabaseConnection__Singleton = Nothing | |||
| ' Factory function | |||
| Function DatabaseConnection() | |||
| If DatabaseConnection__Singleton Is Nothing Then | |||
| Set DatabaseConnection__Singleton = New DatabaseConnection_Class | |||
| End If | |||
| Set DatabaseConnection = DatabaseConnection__Singleton | |||
| End Function | |||
| '------------------------------------------------------------------------------ | |||
| ' Class definition | |||
| '------------------------------------------------------------------------------ | |||
| Class DatabaseConnection_Class | |||
| Private conn ' holds the ADODB.Connection instance | |||
| '---------------------------------------- | |||
| ' Connect to an Access (.mdb/.accdb) file | |||
| '---------------------------------------- | |||
| Public Function ConnectToAccessDatabase(dataSource, provider) | |||
| If IsEmpty(provider) Or provider = "" Then | |||
| provider = "Microsoft.Jet.OLEDB.4.0" | |||
| End If | |||
| Dim connStr | |||
| connStr = "Provider=" & provider & ";" & _ | |||
| "Data Source=" & dataSource & ";" & _ | |||
| "Persist Security Info=False;" | |||
| Set ConnectToAccessDatabase = Me.Connect(connStr) | |||
| End Function | |||
| '---------------------------------------- | |||
| ' Connect to SQL Server | |||
| '---------------------------------------- | |||
| Public Function ConnectToSQLServer(server, database, uid, pwd, useTrusted) | |||
| Dim connStr | |||
| If useTrusted = True Then | |||
| connStr = "Provider=SQLOLEDB;" & _ | |||
| "Server=" & server & ";" & _ | |||
| "Database=" & database & ";" & _ | |||
| "Trusted_Connection=Yes;" | |||
| Else | |||
| connStr = "Provider=SQLOLEDB;" & _ | |||
| "Server=" & server & ";" & _ | |||
| "Database=" & database & ";" & _ | |||
| "User ID=" & uid & ";" & _ | |||
| "Password=" & pwd & ";" | |||
| End If | |||
| Set ConnectToSQLServer = Me.Connect(connStr) | |||
| End Function | |||
| '---------------------------------------- | |||
| ' Connect via ODBC DSN | |||
| '---------------------------------------- | |||
| Public Function ConnectToODBC(dsnName, uid, pwd) | |||
| Dim connStr | |||
| connStr = "DSN=" & dsnName & ";" | |||
| If Not IsEmpty(uid) Then connStr = connStr & "UID=" & uid & ";" | |||
| If Not IsEmpty(pwd) Then connStr = connStr & "PWD=" & pwd & ";" | |||
| Set ConnectToODBC = Me.Connect(connStr) | |||
| End Function | |||
| '---------------------------------------- | |||
| ' Generic Connect: opens and returns an ADODB.Connection | |||
| ' Includes separate handling for creation and open errors | |||
| '---------------------------------------- | |||
| Public Function Connect(connectionString) | |||
| On Error Resume Next | |||
| ' Dispose previous connection if any | |||
| If Not conn Is Nothing Then | |||
| conn.Close | |||
| Set conn = Nothing | |||
| End If | |||
| ' Create ADO Connection object | |||
| Set conn = Server.CreateObject("ADODB.Connection") | |||
| If conn Is Nothing Then | |||
| Err.Clear | |||
| On Error GoTo 0 | |||
| Err.Raise 50000, _ | |||
| "DatabaseConnection_Class.Connect", _ | |||
| "Could not create ADODB.Connection. Ensure ADO is installed and registered." | |||
| End If | |||
| ' Clear any prior errors before opening | |||
| Err.Clear | |||
| ' Open database connection | |||
| conn.Open connectionString | |||
| If Err.Number <> 0 Then | |||
| Dim lastErrNum, lastErrDesc | |||
| lastErrNum = Err.Number | |||
| lastErrDesc = Err.Description | |||
| Err.Clear | |||
| On Error GoTo 0 | |||
| Err.Raise lastErrNum, _ | |||
| "DatabaseConnection_Class.Connect", _ | |||
| "Failed to open connection (" & connectionString & _ | |||
| ") - Error " & lastErrNum & ": " & lastErrDesc | |||
| End If | |||
| On Error GoTo 0 | |||
| Set Connect = conn | |||
| End Function | |||
| '---------------------------------------- | |||
| ' Close & clean up | |||
| '---------------------------------------- | |||
| Public Sub Close() | |||
| On Error Resume Next | |||
| If Not conn Is Nothing Then | |||
| conn.Close | |||
| Set conn = Nothing | |||
| End If | |||
| On Error GoTo 0 | |||
| End Sub | |||
| End Class | |||
| %> | |||
| @@ -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 = " " | |||
| 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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -0,0 +1,109 @@ | |||
| <% | |||
| '======================================================================================================================= | |||
| ' 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 application controllers here. | |||
| ' Format: m_controllers.Add "controllername", True | |||
| RegisterController "homecontroller" | |||
| 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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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='>>'>" | |||
| ' 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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -0,0 +1,52 @@ | |||
| <% | |||
| '========================== | |||
| ' AD_Auth_Class.asp | |||
| '========================== | |||
| Class AD_Auth_Class | |||
| Public DomainName ' e.g. yourdomain.local | |||
| Public ContainerDN ' e.g. DC=yourdomain,DC=local | |||
| Public Username | |||
| Public Password | |||
| Public ErrorMessage | |||
| Public IsAuthenticated | |||
| Public UserObject | |||
| Private Sub Class_Initialize() | |||
| IsAuthenticated = False | |||
| ErrorMessage = "" | |||
| Set UserObject = Nothing | |||
| End Sub | |||
| Public Function Authenticate() | |||
| On Error Resume Next | |||
| Dim ldapPath, userCredential | |||
| ldapPath = "LDAP://" & ContainerDN ' Must be DC=yourdomain,DC=local | |||
| userCredential = DomainName & "\" & Username | |||
| ' Try to bind to Active Directory | |||
| Dim rootDSE : Set rootDSE = GetObject("LDAP:") | |||
| Set UserObject = rootDSE.OpenDSObject(ldapPath, userCredential, Password, 1) | |||
| If Err.Number <> 0 Then | |||
| ErrorMessage = "Authentication failed: " & Err.Description | |||
| IsAuthenticated = False | |||
| Set UserObject = Nothing | |||
| Else | |||
| IsAuthenticated = True | |||
| ErrorMessage = "" | |||
| End If | |||
| Authenticate = IsAuthenticated | |||
| On Error GoTo 0 | |||
| End Function | |||
| End Class | |||
| dim AD_Auth_Class__Singleton | |||
| Function AdAuth() | |||
| if IsEmpty(AD_Auth_Class__Singleton) then | |||
| set AD_Auth_Class__Singleton = new AD_Auth_Class | |||
| end if | |||
| set AdAuth = AD_Auth_Class__Singleton | |||
| End Function | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -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 | |||
| %> | |||
| @@ -0,0 +1,173 @@ | |||
| <!--#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) | |||
| ' A blank route is the router's no-match result. | |||
| If Len(Trim(controllerName)) = 0 Or Len(Trim(actionName)) = 0 Then | |||
| Response.Status = "404 Not Found" | |||
| Response.Write "Not Found" | |||
| Exit Sub | |||
| End If | |||
| ' 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 | |||
| %> | |||
| @@ -0,0 +1,148 @@ | |||
| <?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 | |||
| ' No route matched. The dispatcher emits a neutral 404 response so a | |||
| ' clean application does not need a built-in error controller. | |||
| Resolve = Array("", "", 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> | |||
| @@ -0,0 +1,12 @@ | |||
| <!--#include file="..\core\autoload_core.asp" --> | |||
| <% | |||
| ' Home page routes | |||
| router.AddRoute "GET", "/", "HomeController", "Index" | |||
| router.AddRoute "GET", "", "HomeController", "Index" | |||
| router.AddRoute "GET", "/home", "HomeController", "Index" | |||
| ' Dispatch the request (resolves route and executes controller action) | |||
| MVC.DispatchRequest Request.ServerVariables("REQUEST_METHOD"), _ | |||
| TrimQueryParams(Request.ServerVariables("HTTP_X_ORIGINAL_URL")) | |||
| %> | |||
| @@ -0,0 +1,18 @@ | |||
| # Sharp PostcardMojo Logo Set | |||
| This directory contains recreated, sharper counterparts to the original logo | |||
| assets. The originals remain unchanged in the sibling `jpg/` and `png/` | |||
| directories. | |||
| ## Contents | |||
| - `masters/postcardmojo-full-master.png` — high-resolution transparent wordmark | |||
| - `masters/postcardmojo-icon-master.png` — high-resolution transparent icon | |||
| - `png/` — transparent sharp assets at the original filenames and dimensions | |||
| - `jpg/` — white-background sharp assets at the original filenames and dimensions | |||
| The `logo_full_medium_b_misprint` filename is retained for compatibility, but | |||
| the recreated image uses the correctly spelled `postcardmojo.com` wordmark. | |||
| The production landing page uses the sharp JPG variants at their native pixel | |||
| dimensions so the browser does not resize them. | |||
| @@ -0,0 +1,69 @@ | |||
| <?xml version="1.0" encoding="UTF-8"?> | |||
| <configuration> | |||
| <appSettings> | |||
| <!-- | |||
| Optional Access connection string. Change Data Source after creating | |||
| the application's database, or replace this setting for another store. | |||
| --> | |||
| <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> | |||
| @@ -0,0 +1,4 @@ | |||
| @echo off | |||
| setlocal | |||
| set "ASPC_STARTER_ROOT=%~dp0" | |||
| "C:\Program Files\IIS Express\iisexpress.exe" /config:"%~dp0applicationhost.config" | |||
| @@ -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 | |||
| @@ -0,0 +1,320 @@ | |||
| <# | |||
| .SYNOPSIS | |||
| Validates, packages, and deploys this repository to its dedicated IIS site. | |||
| .DESCRIPTION | |||
| The controller packages the complete repository, computes SHA-256, transfers | |||
| the package and host installer over OpenSSH, and invokes the installer. | |||
| -LocalPreflightOnly validates source provenance, XML, package layout, and | |||
| archive safety without connecting. -PreflightOnly additionally streams the | |||
| installer to the host and runs its read-only IIS preflight without writing a | |||
| remote installer or package. | |||
| #> | |||
| [CmdletBinding()] | |||
| param( | |||
| [ValidatePattern('^[A-Za-z0-9_. -]+$')] | |||
| [string]$SiteName = 'AspClassicUnifiedFramework', | |||
| [ValidatePattern('^[A-Za-z0-9_. -]+$')] | |||
| [string]$AppPoolName = 'AspClassicUnifiedFramework', | |||
| [string]$DeployRoot = 'D:\Deployments\AspClassicUnifiedFramework', | |||
| [string]$BindingIpAddress = '100.97.39.23', | |||
| [ValidateRange(1, 65535)] | |||
| [int]$BindingPort = 8085, | |||
| [AllowEmptyString()] | |||
| [string]$HostHeader = '', | |||
| [string]$InitialWebConfigPath = '', | |||
| [string]$RemoteTarget = 'webserver-1', | |||
| [ValidateRange(1, 65535)] | |||
| [int]$RemotePort = 22, | |||
| [string]$SourcePath = (Split-Path $PSScriptRoot -Parent), | |||
| [string]$BaseUrl = '', | |||
| [string]$ReleaseId = '', | |||
| [string]$ExpectedBranch = 'master', | |||
| [ValidateRange(2, 100)] | |||
| [int]$KeepReleases = 5, | |||
| [string]$SshExe = 'ssh', | |||
| [string]$ScpExe = 'scp', | |||
| [switch]$AllowAnyBranch, | |||
| [switch]$AllowDirty, | |||
| [switch]$RunMigrations, | |||
| [switch]$SkipSmokeTest, | |||
| [Alias('HostPreflightOnly', 'RemotePreflightOnly')] | |||
| [switch]$PreflightOnly, | |||
| [switch]$LocalPreflightOnly, | |||
| [switch]$Rollback, | |||
| [string]$RollbackTo = '', | |||
| [switch]$DryRun, | |||
| [switch]$KeepPackage | |||
| ) | |||
| Set-StrictMode -Version 2.0 | |||
| $ErrorActionPreference = 'Stop' | |||
| function Write-Step { param([string]$Message) Write-Host ('==> ' + $Message) } | |||
| function Assert-Command { | |||
| param([string]$Name) | |||
| if (-not (Get-Command $Name -ErrorAction SilentlyContinue)) { | |||
| throw "$Name was not found on PATH." | |||
| } | |||
| } | |||
| function ConvertTo-SingleQuotedPowerShell { | |||
| param([string]$Value) | |||
| return "'" + $Value.Replace("'", "''") + "'" | |||
| } | |||
| function Add-RemoteArgument { | |||
| param( | |||
| [System.Collections.Generic.List[string]]$Arguments, | |||
| [string]$Name, | |||
| [string]$Value | |||
| ) | |||
| $Arguments.Add($Name) | |||
| $Arguments.Add((ConvertTo-SingleQuotedPowerShell $Value)) | |||
| } | |||
| function Assert-SafeNameValue { | |||
| param([string]$Name, [string]$Value) | |||
| if ([string]::IsNullOrWhiteSpace($Value) -or $Value -notmatch '^[A-Za-z0-9_. -]+$') { | |||
| throw "$Name contains unsupported characters." | |||
| } | |||
| if ($Value -match '(?i)schedulicious') { | |||
| throw "$Name must not identify a Schedulicious resource." | |||
| } | |||
| } | |||
| function Assert-SafeDeploymentValues { | |||
| Assert-SafeNameValue -Name 'SiteName' -Value $SiteName | |||
| Assert-SafeNameValue -Name 'AppPoolName' -Value $AppPoolName | |||
| if ($DeployRoot -match '(?i)schedulicious') { | |||
| throw 'DeployRoot must not reference Schedulicious.' | |||
| } | |||
| if ([string]::IsNullOrWhiteSpace($BindingIpAddress)) { | |||
| throw 'BindingIpAddress must not be empty.' | |||
| } | |||
| $parsedAddress = $null | |||
| if (-not [System.Net.IPAddress]::TryParse($BindingIpAddress, [ref]$parsedAddress)) { | |||
| throw "BindingIpAddress is not a valid IP address: $BindingIpAddress" | |||
| } | |||
| if ($HostHeader -match '[:/\\]') { | |||
| throw 'HostHeader must be empty or a DNS host name without a scheme, port, slash, or backslash.' | |||
| } | |||
| if ($HostHeader -match '(?i)schedulicious') { | |||
| throw 'HostHeader must not reference Schedulicious.' | |||
| } | |||
| } | |||
| function Copy-ReleaseSource { | |||
| param([string]$From, [string]$To) | |||
| $excludedNames = @('.git', '.deployment', 'releases') | |||
| $packageRoots = @(Get-ChildItem -LiteralPath $From -Force | Where-Object { $excludedNames -notcontains $_.Name }) | |||
| $unsafeSourceItem = $packageRoots | | |||
| ForEach-Object { | |||
| if (($_.Attributes -band [IO.FileAttributes]::ReparsePoint) -ne 0) { $_ } | |||
| elseif ($_.PSIsContainer) { Get-ChildItem -LiteralPath $_.FullName -Recurse -Force } | |||
| } | | |||
| Where-Object { ($_.Attributes -band [IO.FileAttributes]::ReparsePoint) -ne 0 } | | |||
| Select-Object -First 1 | |||
| if ($null -ne $unsafeSourceItem) { | |||
| throw "Source contains a reparse point/symbolic link, which is not package-safe: $($unsafeSourceItem.FullName)" | |||
| } | |||
| New-Item -ItemType Directory -Force -Path $To | Out-Null | |||
| $packageRoots | ForEach-Object { | |||
| if ($excludedNames -contains $_.Name) { return } | |||
| if (($_.Attributes -band [IO.FileAttributes]::ReparsePoint) -ne 0) { | |||
| throw "Source contains a reparse point/symbolic link, which is not package-safe: $($_.FullName)" | |||
| } | |||
| Copy-Item -LiteralPath $_.FullName -Destination $To -Recurse -Force | |||
| } | |||
| $unsafeEntry = Get-ChildItem -LiteralPath $To -Recurse -Force | | |||
| Where-Object { ($_.Attributes -band [IO.FileAttributes]::ReparsePoint) -ne 0 } | | |||
| Select-Object -First 1 | |||
| if ($null -ne $unsafeEntry) { | |||
| throw "Package staging contains a reparse point/symbolic link: $($unsafeEntry.FullName)" | |||
| } | |||
| } | |||
| function Assert-ReleaseLayout { | |||
| param([string]$Root) | |||
| $required = @( | |||
| 'public\Default.asp', | |||
| 'public\web.config', | |||
| 'core\autoload_core.asp', | |||
| 'app\controllers\autoload_controllers.asp', | |||
| 'scripts\install-iis-release.ps1' | |||
| ) | |||
| foreach ($relativePath in $required) { | |||
| if (-not (Test-Path -LiteralPath (Join-Path $Root $relativePath) -PathType Leaf)) { | |||
| throw "Package/source tree is incomplete; missing $relativePath" | |||
| } | |||
| } | |||
| foreach ($xmlFile in Get-ChildItem -LiteralPath $Root -Recurse -Force -Filter 'web.config') { | |||
| try { | |||
| [xml](Get-Content -LiteralPath $xmlFile.FullName -Raw) | Out-Null | |||
| } catch { | |||
| throw "$($xmlFile.FullName) is not valid XML: $($_.Exception.Message)" | |||
| } | |||
| } | |||
| } | |||
| Assert-SafeDeploymentValues | |||
| $SourcePath = [System.IO.Path]::GetFullPath($SourcePath) | |||
| $installerPath = Join-Path $PSScriptRoot 'install-iis-release.ps1' | |||
| Assert-ReleaseLayout -Root $SourcePath | |||
| $directGitRoot = Test-Path -LiteralPath (Join-Path $SourcePath '.git') | |||
| $commit = 'nogit' | |||
| if ($directGitRoot) { | |||
| Assert-Command 'git' | |||
| $branch = (& git -C $SourcePath branch --show-current).Trim() | |||
| if ($LASTEXITCODE -ne 0) { throw 'Could not determine the Git branch.' } | |||
| if ((-not $AllowAnyBranch) -and $branch -ne $ExpectedBranch) { | |||
| throw "Refusing to deploy branch '$branch'; expected '$ExpectedBranch'." | |||
| } | |||
| $dirty = & git -C $SourcePath status --porcelain | |||
| if ($LASTEXITCODE -ne 0) { throw 'Could not inspect the Git worktree.' } | |||
| if ((-not $AllowDirty) -and $null -ne $dirty -and @($dirty).Count -gt 0) { | |||
| throw 'Refusing to deploy a dirty worktree. Use -AllowDirty only for a reviewed exception.' | |||
| } | |||
| $commit = (& git -C $SourcePath rev-parse --short=12 HEAD).Trim() | |||
| if ($LASTEXITCODE -ne 0) { throw 'Could not determine the Git commit.' } | |||
| Write-Host "Source branch: $branch" | |||
| Write-Host "Source commit: $commit" | |||
| } else { | |||
| Write-Warning 'SourcePath is not a standalone Git checkout; branch and dirty-worktree checks cannot be enforced.' | |||
| if (-not $AllowAnyBranch) { | |||
| throw 'Use a standalone checkout, or pass -AllowAnyBranch for a reviewed non-Git source tree.' | |||
| } | |||
| } | |||
| if ([string]::IsNullOrWhiteSpace($ReleaseId)) { | |||
| $ReleaseId = (Get-Date -Format 'yyyyMMdd-HHmmss') + '-' + $commit | |||
| } | |||
| if ($ReleaseId -notmatch '^[A-Za-z0-9._-]+$') { throw 'ReleaseId contains unsupported characters.' } | |||
| if ($Rollback -and [string]::IsNullOrWhiteSpace($RollbackTo)) { throw '-Rollback requires -RollbackTo.' } | |||
| if ((-not $Rollback) -and -not [string]::IsNullOrWhiteSpace($RollbackTo)) { throw '-RollbackTo requires -Rollback.' } | |||
| if ($RunMigrations -and $Rollback) { throw '-RunMigrations is not valid during rollback.' } | |||
| if (($PreflightOnly -or $LocalPreflightOnly) -and $Rollback) { | |||
| throw 'Preflight modes cannot be combined with -Rollback.' | |||
| } | |||
| if ($PreflightOnly -and $LocalPreflightOnly) { | |||
| throw '-PreflightOnly and -LocalPreflightOnly are mutually exclusive.' | |||
| } | |||
| $workRoot = Join-Path ([System.IO.Path]::GetTempPath()) ('asp-iis-deploy-' + [Guid]::NewGuid().ToString('N')) | |||
| $packageStage = Join-Path $workRoot 'package' | |||
| $packageExtract = Join-Path $workRoot 'verify' | |||
| $packagePath = Join-Path $workRoot ($ReleaseId + '.zip') | |||
| $remoteDirectory = 'C:\Windows\Temp\asp-iis-deploy-' + $ReleaseId | |||
| $remotePackage = $remoteDirectory + '\' + $ReleaseId + '.zip' | |||
| $remoteInstaller = $remoteDirectory + '\install-iis-release.ps1' | |||
| try { | |||
| $sha256 = '' | |||
| if (-not $Rollback) { | |||
| Write-Step 'Staging the complete repository for packaging' | |||
| Copy-ReleaseSource -From $SourcePath -To $packageStage | |||
| Assert-ReleaseLayout -Root $packageStage | |||
| Add-Type -AssemblyName System.IO.Compression.FileSystem | |||
| [System.IO.Compression.ZipFile]::CreateFromDirectory($packageStage, $packagePath, [System.IO.Compression.CompressionLevel]::Optimal, $false) | |||
| [System.IO.Compression.ZipFile]::ExtractToDirectory($packagePath, $packageExtract) | |||
| Assert-ReleaseLayout -Root $packageExtract | |||
| $sha256 = (Get-FileHash -LiteralPath $packagePath -Algorithm SHA256).Hash | |||
| Write-Host "Package: $packagePath" | |||
| Write-Host "SHA-256: $sha256" | |||
| } | |||
| if ($LocalPreflightOnly) { | |||
| Write-Step 'Local/controller preflight passed; no network connection or host change was made' | |||
| exit 0 | |||
| } | |||
| $remoteArguments = New-Object 'System.Collections.Generic.List[string]' | |||
| $remoteArguments.Add('&') | |||
| $remoteArguments.Add((ConvertTo-SingleQuotedPowerShell $remoteInstaller)) | |||
| Add-RemoteArgument $remoteArguments '-SiteName' $SiteName | |||
| Add-RemoteArgument $remoteArguments '-AppPoolName' $AppPoolName | |||
| Add-RemoteArgument $remoteArguments '-DeployRoot' $DeployRoot | |||
| Add-RemoteArgument $remoteArguments '-BindingIpAddress' $BindingIpAddress | |||
| Add-RemoteArgument $remoteArguments '-BindingPort' $BindingPort.ToString() | |||
| Add-RemoteArgument $remoteArguments '-HostHeader' $HostHeader | |||
| Add-RemoteArgument $remoteArguments '-KeepReleases' $KeepReleases.ToString() | |||
| if (-not [string]::IsNullOrWhiteSpace($InitialWebConfigPath)) { Add-RemoteArgument $remoteArguments '-InitialWebConfigPath' $InitialWebConfigPath } | |||
| if (-not [string]::IsNullOrWhiteSpace($BaseUrl)) { Add-RemoteArgument $remoteArguments '-BaseUrl' $BaseUrl } | |||
| if ($Rollback) { | |||
| Add-RemoteArgument $remoteArguments '-RollbackTo' $RollbackTo | |||
| } elseif ($PreflightOnly) { | |||
| $remoteArguments.Add('-PreflightOnly') | |||
| } else { | |||
| Add-RemoteArgument $remoteArguments '-PackagePath' $remotePackage | |||
| Add-RemoteArgument $remoteArguments '-ReleaseId' $ReleaseId | |||
| Add-RemoteArgument $remoteArguments '-ExpectedSha256' $sha256 | |||
| } | |||
| if ($RunMigrations) { $remoteArguments.Add('-RunMigrations') } | |||
| if ($SkipSmokeTest) { $remoteArguments.Add('-SkipSmokeTest') } | |||
| $remoteScript = $remoteArguments -join ' ' | |||
| $remoteEncodedCommand = [Convert]::ToBase64String([Text.Encoding]::Unicode.GetBytes($remoteScript)) | |||
| $remoteCommand = 'powershell.exe -NoProfile -NonInteractive -ExecutionPolicy RemoteSigned -EncodedCommand ' + $remoteEncodedCommand | |||
| if ($DryRun) { | |||
| Write-Step 'Dry-run complete; no network connection was made' | |||
| Write-Host "Would use dedicated site '$SiteName' and app pool '$AppPoolName'." | |||
| Write-Host "Would use binding ${BindingIpAddress}:$BindingPort with host header '$HostHeader'." | |||
| if ($PreflightOnly) { | |||
| Write-Host 'Would stream the installer over SSH for a read-only host preflight; no remote file would be written.' | |||
| } else { | |||
| Write-Host "Would create remote directory: $remoteDirectory" | |||
| Write-Host "Would copy installer: $installerPath" | |||
| if (-not $Rollback) { Write-Host "Would copy package: $packagePath" } | |||
| Write-Host ('Would execute host script: ' + $remoteScript) | |||
| } | |||
| exit 0 | |||
| } | |||
| Assert-Command $SshExe | |||
| if ($PreflightOnly) { | |||
| Write-Step 'Streaming the installer for read-only host preflight' | |||
| $installerSource = Get-Content -LiteralPath $installerPath -Raw | |||
| $argumentTail = @($remoteArguments | Select-Object -Skip 2) -join ' ' | |||
| $stdinScript = "& {`r`n" + $installerSource + "`r`n} " + $argumentTail | |||
| $stdinScript | & $SshExe -p $RemotePort $RemoteTarget 'powershell.exe -NoProfile -NonInteractive -ExecutionPolicy RemoteSigned -Command -' | |||
| if ($LASTEXITCODE -ne 0) { throw "Remote preflight failed with exit code $LASTEXITCODE." } | |||
| Write-Step 'Remote host preflight completed successfully without persistent host changes' | |||
| exit 0 | |||
| } | |||
| Assert-Command $ScpExe | |||
| Write-Step 'Creating remote temporary directory' | |||
| $mkdirScript = "New-Item -ItemType Directory -Force -Path $(ConvertTo-SingleQuotedPowerShell $remoteDirectory) | Out-Null" | |||
| $mkdirEncoded = [Convert]::ToBase64String([Text.Encoding]::Unicode.GetBytes($mkdirScript)) | |||
| & $SshExe -p $RemotePort $RemoteTarget ('powershell.exe -NoProfile -NonInteractive -EncodedCommand ' + $mkdirEncoded) | |||
| if ($LASTEXITCODE -ne 0) { throw 'Remote directory creation failed.' } | |||
| Write-Step 'Copying the host installer' | |||
| & $ScpExe -P $RemotePort $installerPath ($RemoteTarget + ':' + $remoteDirectory.Replace('\', '/') + '/install-iis-release.ps1') | |||
| if ($LASTEXITCODE -ne 0) { throw 'Installer copy failed.' } | |||
| if (-not $Rollback) { | |||
| Write-Step 'Copying the release package' | |||
| & $ScpExe -P $RemotePort $packagePath ($RemoteTarget + ':' + $remoteDirectory.Replace('\', '/') + '/' + $ReleaseId + '.zip') | |||
| if ($LASTEXITCODE -ne 0) { throw 'Package copy failed.' } | |||
| } | |||
| Write-Step 'Invoking the host-side installer' | |||
| & $SshExe -p $RemotePort $RemoteTarget $remoteCommand | |||
| if ($LASTEXITCODE -ne 0) { throw "Remote installer failed with exit code $LASTEXITCODE." } | |||
| Write-Step 'Remote operation completed successfully' | |||
| } finally { | |||
| if ($KeepPackage -and (Test-Path -LiteralPath $packagePath)) { | |||
| $keptPath = Join-Path (Get-Location) ([System.IO.Path]::GetFileName($packagePath)) | |||
| Copy-Item -LiteralPath $packagePath -Destination $keptPath -Force | |||
| Write-Host "Package retained at $keptPath" | |||
| } | |||
| if (Test-Path -LiteralPath $workRoot) { Remove-Item -LiteralPath $workRoot -Recurse -Force } | |||
| } | |||
| @@ -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 | |||
| @@ -0,0 +1,476 @@ | |||
| <# | |||
| .SYNOPSIS | |||
| Installs or rolls back an immutable release in a dedicated IIS site/app pool. | |||
| .DESCRIPTION | |||
| The complete repository is retained in each immutable release and IIS serves | |||
| only <release>\public. The script never discovers or adopts another site. | |||
| A missing dedicated target is created only after package extraction, layout, | |||
| and XML validation succeed. Host preflight is read-only and does not require | |||
| the dedicated target to exist. | |||
| #> | |||
| [CmdletBinding(DefaultParameterSetName = 'Deploy')] | |||
| param( | |||
| [ValidatePattern('^[A-Za-z0-9_. -]+$')] | |||
| [string]$SiteName = 'AspClassicUnifiedFramework', | |||
| [ValidatePattern('^[A-Za-z0-9_. -]+$')] | |||
| [string]$AppPoolName = 'AspClassicUnifiedFramework', | |||
| [string]$DeployRoot = 'D:\Deployments\AspClassicUnifiedFramework', | |||
| [string]$BindingIpAddress = '100.97.39.23', | |||
| [ValidateRange(1, 65535)] | |||
| [int]$BindingPort = 8085, | |||
| [AllowEmptyString()] | |||
| [string]$HostHeader = '', | |||
| [string]$InitialWebConfigPath = '', | |||
| [Parameter(ParameterSetName = 'Deploy')] | |||
| [string]$PackagePath = '', | |||
| [Parameter(ParameterSetName = 'Deploy')] | |||
| [ValidatePattern('^[A-Za-z0-9._-]+$')] | |||
| [string]$ReleaseId = (Get-Date -Format 'yyyyMMdd-HHmmss'), | |||
| [Parameter(Mandatory = $true, ParameterSetName = 'Rollback')] | |||
| [ValidatePattern('^[A-Za-z0-9._-]+$')] | |||
| [string]$RollbackTo, | |||
| [string]$BaseUrl = '', | |||
| [ValidateRange(2, 100)] | |||
| [int]$KeepReleases = 5, | |||
| [string]$ExpectedSha256 = '', | |||
| [switch]$RunMigrations, | |||
| [switch]$SkipSmokeTest, | |||
| [switch]$PreflightOnly, | |||
| [switch]$DryRun | |||
| ) | |||
| Set-StrictMode -Version 2.0 | |||
| $ErrorActionPreference = 'Stop' | |||
| function Write-Step { param([string]$Message) Write-Host ('==> ' + $Message) } | |||
| function Get-NormalizedPath { | |||
| param([string]$Path) | |||
| return [System.IO.Path]::GetFullPath([Environment]::ExpandEnvironmentVariables($Path)).TrimEnd('\') | |||
| } | |||
| function Assert-Administrator { | |||
| $identity = [Security.Principal.WindowsIdentity]::GetCurrent() | |||
| $principal = New-Object Security.Principal.WindowsPrincipal($identity) | |||
| if (-not $principal.IsInRole([Security.Principal.WindowsBuiltInRole]::Administrator)) { | |||
| throw 'An elevated Administrator PowerShell session is required.' | |||
| } | |||
| } | |||
| function Assert-SafeNameValue { | |||
| param([string]$Name, [string]$Value) | |||
| if ([string]::IsNullOrWhiteSpace($Value) -or $Value -notmatch '^[A-Za-z0-9_. -]+$') { | |||
| throw "$Name contains unsupported characters." | |||
| } | |||
| if ($Value -match '(?i)schedulicious') { | |||
| throw "$Name must not identify a Schedulicious resource." | |||
| } | |||
| } | |||
| function Assert-DeploymentInputs { | |||
| Assert-SafeNameValue -Name 'SiteName' -Value $SiteName | |||
| Assert-SafeNameValue -Name 'AppPoolName' -Value $AppPoolName | |||
| if ($DeployRoot -match '(?i)schedulicious') { throw 'DeployRoot must not reference Schedulicious.' } | |||
| if ($HostHeader -match '(?i)schedulicious') { throw 'HostHeader must not reference Schedulicious.' } | |||
| if ($HostHeader -match '[:/\\]') { | |||
| throw 'HostHeader must be empty or a DNS host name without a scheme, port, slash, or backslash.' | |||
| } | |||
| $parsedAddress = $null | |||
| if (-not [System.Net.IPAddress]::TryParse($BindingIpAddress, [ref]$parsedAddress)) { | |||
| throw "BindingIpAddress is not a valid IP address: $BindingIpAddress" | |||
| } | |||
| } | |||
| function Assert-ReleaseLayout { | |||
| param([string]$ReleasePath) | |||
| $required = @( | |||
| 'public\Default.asp', | |||
| 'public\web.config', | |||
| 'core\autoload_core.asp', | |||
| 'app\controllers\autoload_controllers.asp', | |||
| 'scripts\install-iis-release.ps1' | |||
| ) | |||
| foreach ($relativePath in $required) { | |||
| if (-not (Test-Path -LiteralPath (Join-Path $ReleasePath $relativePath) -PathType Leaf)) { | |||
| throw "Release is incomplete; missing $relativePath" | |||
| } | |||
| } | |||
| foreach ($xmlFile in Get-ChildItem -LiteralPath $ReleasePath -Recurse -Force -Filter 'web.config') { | |||
| try { | |||
| [xml](Get-Content -LiteralPath $xmlFile.FullName -Raw) | Out-Null | |||
| } catch { | |||
| throw "$($xmlFile.FullName) is not valid XML: $($_.Exception.Message)" | |||
| } | |||
| } | |||
| } | |||
| function Assert-ArchiveEntries { | |||
| param([string]$ZipPath) | |||
| Add-Type -AssemblyName System.IO.Compression.FileSystem | |||
| $archive = [System.IO.Compression.ZipFile]::OpenRead($ZipPath) | |||
| try { | |||
| foreach ($entry in $archive.Entries) { | |||
| $name = $entry.FullName.Replace('/', '\') | |||
| if ([System.IO.Path]::IsPathRooted($name) -or $name -match '(^|\\)\.\.(\\|$)') { | |||
| throw "Package contains an unsafe path: $($entry.FullName)" | |||
| } | |||
| } | |||
| } finally { | |||
| $archive.Dispose() | |||
| } | |||
| } | |||
| function Get-BindingInformation { | |||
| return $BindingIpAddress + ':' + $BindingPort + ':' + $HostHeader | |||
| } | |||
| function Assert-HostCapabilities { | |||
| # Query IIS directly instead of Get-WindowsFeature/Get-WindowsOptionalFeature: | |||
| # those feature cmdlets can stall while collecting server-manager state. | |||
| $aspHandler = (Get-WebConfiguration -PSPath 'MACHINE/WEBROOT/APPHOST' -Filter 'system.webServer/handlers').Collection | | |||
| Where-Object { $_.path -eq '*.asp' -and $_.modules -match '(^|,)IsapiModule(,|$)' -and $_.scriptProcessor -match '(?i)asp\.dll$' } | | |||
| Select-Object -First 1 | |||
| if ($null -eq $aspHandler) { | |||
| throw 'The IIS Classic ASP handler (*.asp through asp.dll) was not found.' | |||
| } | |||
| try { | |||
| Get-WebConfigurationProperty -PSPath 'MACHINE/WEBROOT/APPHOST' -Filter 'system.webServer/asp' -Name 'enableParentPaths' -ErrorAction Stop | Out-Null | |||
| } catch { | |||
| throw "The IIS Classic ASP configuration section is unavailable: $($_.Exception.Message)" | |||
| } | |||
| if ($null -eq (Get-WebGlobalModule -Name RewriteModule -ErrorAction SilentlyContinue)) { | |||
| throw 'IIS URL Rewrite is not installed (RewriteModule was not found).' | |||
| } | |||
| } | |||
| function Assert-DeployRoot { | |||
| param([string]$Path) | |||
| $root = [System.IO.Path]::GetPathRoot($Path) | |||
| if ([string]::IsNullOrWhiteSpace($root) -or -not (Test-Path -LiteralPath $root -PathType Container)) { | |||
| throw "The deployment drive/root is unavailable: $root" | |||
| } | |||
| if ($Path.TrimEnd('\') -eq $root.TrimEnd('\')) { throw 'DeployRoot must not be a drive root.' } | |||
| if ((Test-Path -LiteralPath $Path) -and -not (Test-Path -LiteralPath $Path -PathType Container)) { | |||
| throw "DeployRoot exists but is not a directory: $Path" | |||
| } | |||
| $ancestor = $Path | |||
| while (-not (Test-Path -LiteralPath $ancestor -PathType Container)) { | |||
| $parent = Split-Path -Parent $ancestor | |||
| if ([string]::IsNullOrWhiteSpace($parent) -or $parent -eq $ancestor) { break } | |||
| $ancestor = $parent | |||
| } | |||
| if (-not (Test-Path -LiteralPath $ancestor -PathType Container)) { | |||
| throw "No accessible ancestor exists for DeployRoot: $Path" | |||
| } | |||
| Get-Item -LiteralPath $ancestor -ErrorAction Stop | Out-Null | |||
| } | |||
| function Test-PathUnderRoot { | |||
| param([string]$Path, [string]$Root) | |||
| $normalizedPath = Get-NormalizedPath $Path | |||
| $prefix = (Get-NormalizedPath $Root) + '\' | |||
| return $normalizedPath.StartsWith($prefix, [StringComparison]::OrdinalIgnoreCase) | |||
| } | |||
| function Get-TargetState { | |||
| $site = Get-Website -Name $SiteName -ErrorAction SilentlyContinue | |||
| $poolExists = Test-Path -LiteralPath ('IIS:\AppPools\' + $AppPoolName) | |||
| if (($null -eq $site) -ne (-not $poolExists)) { | |||
| throw 'Dedicated target is partial: the site and app pool must either both exist or both be absent.' | |||
| } | |||
| if ($null -eq $site) { | |||
| return [pscustomobject]@{ | |||
| Exists = $false; Site = $null; PhysicalPath = ''; ParentPaths = $null | |||
| SiteState = ''; PoolState = '' | |||
| } | |||
| } | |||
| if ($site.applicationPool -ne $AppPoolName) { | |||
| throw "Existing target site uses app pool '$($site.applicationPool)', expected '$AppPoolName'. Refusing adoption." | |||
| } | |||
| $otherPoolConsumer = Get-Website | | |||
| Where-Object { $_.Name -ne $SiteName -and $_.applicationPool -eq $AppPoolName } | | |||
| Select-Object -First 1 | |||
| if ($null -ne $otherPoolConsumer) { | |||
| throw "App pool '$AppPoolName' is also used by site '$($otherPoolConsumer.Name)'. Refusing to alter a shared pool." | |||
| } | |||
| $bindings = @($site.Bindings.Collection) | |||
| $expectedBinding = Get-BindingInformation | |||
| if ($bindings.Count -ne 1 -or $bindings[0].protocol -ne 'http' -or $bindings[0].bindingInformation -ne $expectedBinding) { | |||
| throw "Existing target binding does not exactly match http/$expectedBinding. Refusing adoption or binding changes." | |||
| } | |||
| $physicalPath = Get-NormalizedPath $site.physicalPath | |||
| $releasesRoot = Join-Path $DeployRoot 'releases' | |||
| if (-not (Test-PathUnderRoot -Path $physicalPath -Root $releasesRoot) -or | |||
| -not $physicalPath.EndsWith('\public', [StringComparison]::OrdinalIgnoreCase)) { | |||
| throw "Existing target physicalPath is outside this pipeline's release public directories: $physicalPath" | |||
| } | |||
| if (-not (Test-Path -LiteralPath $physicalPath -PathType Container)) { | |||
| throw "Existing target physicalPath does not exist: $physicalPath" | |||
| } | |||
| Assert-ReleaseLayout -ReleasePath (Split-Path -Parent $physicalPath) | |||
| $parentPaths = (Get-WebConfigurationProperty -PSPath 'MACHINE/WEBROOT/APPHOST' -Location $SiteName -Filter 'system.webServer/asp' -Name 'enableParentPaths').Value | |||
| return [pscustomobject]@{ | |||
| Exists = $true; Site = $site; PhysicalPath = $physicalPath; ParentPaths = [bool]$parentPaths | |||
| SiteState = (Get-WebsiteState -Name $SiteName).Value | |||
| PoolState = (Get-WebAppPoolState -Name $AppPoolName).Value | |||
| } | |||
| } | |||
| function Assert-NoBindingConflict { | |||
| param($TargetState) | |||
| $expectedBinding = Get-BindingInformation | |||
| foreach ($candidate in Get-Website) { | |||
| if ($TargetState.Exists -and $candidate.Name -eq $SiteName) { continue } | |||
| foreach ($binding in @($candidate.Bindings.Collection)) { | |||
| if ($binding.protocol -ne 'http') { continue } | |||
| if ($binding.bindingInformation -notmatch '^(.*):(\d+):(.*)$') { continue } | |||
| $candidateIp = $Matches[1] | |||
| $candidatePort = [int]$Matches[2] | |||
| $candidateHost = $Matches[3] | |||
| $ipOverlaps = ($candidateIp -eq '*' -or $candidateIp -eq '0.0.0.0' -or $candidateIp -eq $BindingIpAddress) | |||
| if ($candidatePort -eq $BindingPort -and $candidateHost -eq $HostHeader -and $ipOverlaps) { | |||
| throw "Requested binding http/$expectedBinding conflicts with existing site '$($candidate.Name)' binding '$($binding.bindingInformation)'." | |||
| } | |||
| } | |||
| } | |||
| } | |||
| function Get-SmokeUrl { | |||
| if (-not [string]::IsNullOrWhiteSpace($BaseUrl)) { return $BaseUrl } | |||
| $hostPart = $BindingIpAddress | |||
| if ($hostPart.Contains(':')) { $hostPart = '[' + $hostPart + ']' } | |||
| return 'http://' + $hostPart + ':' + $BindingPort | |||
| } | |||
| function Invoke-SmokeTest { | |||
| if ($SkipSmokeTest) { | |||
| Write-Step 'Smoke test skipped by explicit request' | |||
| return | |||
| } | |||
| $target = (Get-SmokeUrl).TrimEnd('/') + '/' | |||
| Write-Step ('Smoke testing ' + $target) | |||
| $headers = @{} | |||
| if (-not [string]::IsNullOrWhiteSpace($HostHeader)) { $headers['Host'] = $HostHeader } | |||
| $response = Invoke-WebRequest -UseBasicParsing -Uri $target -Headers $headers -TimeoutSec 30 | |||
| if ($response.StatusCode -lt 200 -or $response.StatusCode -ge 400) { | |||
| throw "Smoke test returned HTTP $($response.StatusCode)" | |||
| } | |||
| Write-Host ('Smoke test returned HTTP ' + $response.StatusCode) | |||
| } | |||
| function Set-IisRelease { | |||
| param([string]$PhysicalPath) | |||
| Set-ItemProperty -Path ('IIS:\Sites\' + $SiteName) -Name physicalPath -Value $PhysicalPath | |||
| $poolState = (Get-WebAppPoolState -Name $AppPoolName).Value | |||
| if ($poolState -eq 'Started') { Restart-WebAppPool -Name $AppPoolName } | |||
| else { Start-WebAppPool -Name $AppPoolName } | |||
| } | |||
| function Restore-ExistingTarget { | |||
| param($TargetState) | |||
| if (-not $TargetState.Exists) { return } | |||
| Set-ItemProperty -Path ('IIS:\Sites\' + $SiteName) -Name physicalPath -Value $TargetState.PhysicalPath | |||
| Set-WebConfigurationProperty -PSPath 'MACHINE/WEBROOT/APPHOST' -Location $SiteName -Filter 'system.webServer/asp' -Name 'enableParentPaths' -Value $TargetState.ParentPaths | |||
| if ($TargetState.PoolState -eq 'Started') { | |||
| if ((Get-WebAppPoolState -Name $AppPoolName).Value -eq 'Started') { Restart-WebAppPool -Name $AppPoolName } | |||
| else { Start-WebAppPool -Name $AppPoolName } | |||
| } elseif ((Get-WebAppPoolState -Name $AppPoolName).Value -eq 'Started') { | |||
| Stop-WebAppPool -Name $AppPoolName | |||
| } | |||
| if ($TargetState.SiteState -eq 'Started') { | |||
| if ((Get-WebsiteState -Name $SiteName).Value -ne 'Started') { Start-Website -Name $SiteName } | |||
| } elseif ((Get-WebsiteState -Name $SiteName).Value -eq 'Started') { | |||
| Stop-Website -Name $SiteName | |||
| } | |||
| } | |||
| if ($env:OS -ne 'Windows_NT') { throw 'This script must run on Windows.' } | |||
| Assert-Administrator | |||
| Import-Module WebAdministration -ErrorAction Stop | |||
| Assert-DeploymentInputs | |||
| $DeployRoot = Get-NormalizedPath $DeployRoot | |||
| Assert-DeployRoot -Path $DeployRoot | |||
| if (-not [string]::IsNullOrWhiteSpace($InitialWebConfigPath)) { | |||
| $preflightInitialConfig = Get-NormalizedPath $InitialWebConfigPath | |||
| if (-not (Test-Path -LiteralPath $preflightInitialConfig -PathType Leaf)) { | |||
| throw "InitialWebConfigPath not found: $preflightInitialConfig" | |||
| } | |||
| try { [xml](Get-Content -LiteralPath $preflightInitialConfig -Raw) | Out-Null } | |||
| catch { throw "InitialWebConfigPath is not valid XML: $($_.Exception.Message)" } | |||
| } | |||
| Assert-HostCapabilities | |||
| $targetState = Get-TargetState | |||
| Assert-NoBindingConflict -TargetState $targetState | |||
| Write-Step "Dedicated site: $SiteName" | |||
| Write-Host "Dedicated app pool: $AppPoolName" | |||
| Write-Host "Binding: http/$(Get-BindingInformation)" | |||
| Write-Host "Deployment root: $DeployRoot" | |||
| if ($targetState.Exists) { | |||
| Write-Host 'Target state: existing and exactly matched' | |||
| } else { | |||
| Write-Host 'Target state: absent; eligible for isolated creation after release validation' | |||
| } | |||
| if ($PreflightOnly -or $DryRun) { | |||
| Write-Step 'Host preflight passed; no IIS or filesystem changes were made' | |||
| exit 0 | |||
| } | |||
| $releasesRoot = Join-Path $DeployRoot 'releases' | |||
| $sharedRoot = Join-Path $DeployRoot 'shared' | |||
| $sharedConfig = Join-Path $sharedRoot 'public.web.config' | |||
| $statePath = Join-Path $DeployRoot 'deployment-state.json' | |||
| if ($PSCmdlet.ParameterSetName -eq 'Rollback') { | |||
| if (-not $targetState.Exists) { throw 'Rollback requires the dedicated target site and app pool to exist.' } | |||
| if (-not (Test-Path -LiteralPath $sharedConfig -PathType Leaf)) { throw "Shared configuration is missing: $sharedConfig" } | |||
| $rollbackRoot = Get-NormalizedPath (Join-Path $releasesRoot $RollbackTo) | |||
| if (-not (Test-PathUnderRoot -Path $rollbackRoot -Root $releasesRoot)) { throw 'Rollback target escaped the releases directory.' } | |||
| Assert-ReleaseLayout -ReleasePath $rollbackRoot | |||
| try { [xml](Get-Content -LiteralPath $sharedConfig -Raw) | Out-Null } | |||
| catch { throw "Shared configuration is not valid XML: $($_.Exception.Message)" } | |||
| try { | |||
| Set-WebConfigurationProperty -PSPath 'MACHINE/WEBROOT/APPHOST' -Location $SiteName -Filter 'system.webServer/asp' -Name 'enableParentPaths' -Value $true | |||
| Set-IisRelease -PhysicalPath (Join-Path $rollbackRoot 'public') | |||
| Invoke-SmokeTest | |||
| [ordered]@{ | |||
| siteName = $SiteName; appPoolName = $AppPoolName; currentRelease = $RollbackTo | |||
| currentPhysicalPath = (Join-Path $rollbackRoot 'public'); previousPhysicalPath = $targetState.PhysicalPath | |||
| binding = (Get-BindingInformation); switchedAtUtc = (Get-Date).ToUniversalTime().ToString('o'); operation = 'rollback' | |||
| } | ConvertTo-Json | Set-Content -LiteralPath $statePath -Encoding UTF8 | |||
| } catch { | |||
| Write-Warning 'Rollback failed; restoring the prior dedicated target path and parent-path setting.' | |||
| Restore-ExistingTarget -TargetState $targetState | |||
| throw | |||
| } | |||
| Write-Step "Rollback complete: $RollbackTo" | |||
| exit 0 | |||
| } | |||
| if ([string]::IsNullOrWhiteSpace($PackagePath)) { throw '-PackagePath is required for deployment.' } | |||
| $PackagePath = Get-NormalizedPath $PackagePath | |||
| if (-not (Test-Path -LiteralPath $PackagePath -PathType Leaf)) { throw "Package not found: $PackagePath" } | |||
| if ([System.IO.Path]::GetExtension($PackagePath) -ne '.zip') { throw 'PackagePath must name a .zip package.' } | |||
| if (-not [string]::IsNullOrWhiteSpace($ExpectedSha256)) { | |||
| $actualHash = (Get-FileHash -LiteralPath $PackagePath -Algorithm SHA256).Hash | |||
| if ($actualHash -ne $ExpectedSha256) { throw "Package SHA-256 mismatch. Expected $ExpectedSha256; got $actualHash" } | |||
| Write-Host ('Package SHA-256 verified: ' + $actualHash) | |||
| } | |||
| Assert-ArchiveEntries -ZipPath $PackagePath | |||
| $releaseRoot = Join-Path $releasesRoot $ReleaseId | |||
| $stagingRoot = $releaseRoot + '.staging' | |||
| if ((Test-Path -LiteralPath $releaseRoot) -or (Test-Path -LiteralPath $stagingRoot)) { throw "Release already exists: $ReleaseId" } | |||
| $createdSite = $false | |||
| $createdPool = $false | |||
| $createdSharedConfig = $false | |||
| $iisMutationStarted = $false | |||
| try { | |||
| New-Item -ItemType Directory -Force -Path $releasesRoot, $sharedRoot | Out-Null | |||
| New-Item -ItemType Directory -Force -Path $stagingRoot | Out-Null | |||
| Expand-Archive -LiteralPath $PackagePath -DestinationPath $stagingRoot -Force | |||
| $unsafeExtractedItem = Get-ChildItem -LiteralPath $stagingRoot -Recurse -Force | | |||
| Where-Object { ($_.Attributes -band [IO.FileAttributes]::ReparsePoint) -ne 0 } | | |||
| Select-Object -First 1 | |||
| if ($null -ne $unsafeExtractedItem) { | |||
| throw "Extracted release contains a reparse point: $($unsafeExtractedItem.FullName)" | |||
| } | |||
| Assert-ReleaseLayout -ReleasePath $stagingRoot | |||
| if (-not (Test-Path -LiteralPath $sharedConfig -PathType Leaf)) { | |||
| $initialConfig = Join-Path $stagingRoot 'public\web.config' | |||
| if (-not [string]::IsNullOrWhiteSpace($InitialWebConfigPath)) { | |||
| $initialConfig = Get-NormalizedPath $InitialWebConfigPath | |||
| if (-not (Test-Path -LiteralPath $initialConfig -PathType Leaf)) { throw "InitialWebConfigPath not found: $initialConfig" } | |||
| } | |||
| try { [xml](Get-Content -LiteralPath $initialConfig -Raw) | Out-Null } | |||
| catch { throw "Initial web.config is not valid XML: $($_.Exception.Message)" } | |||
| Copy-Item -LiteralPath $initialConfig -Destination $sharedConfig -Force | |||
| $createdSharedConfig = $true | |||
| Write-Step "Initialized shared configuration from $initialConfig" | |||
| } | |||
| try { [xml](Get-Content -LiteralPath $sharedConfig -Raw) | Out-Null } | |||
| catch { throw "Shared configuration is not valid XML: $($_.Exception.Message)" } | |||
| Copy-Item -LiteralPath $sharedConfig -Destination (Join-Path $stagingRoot 'public\web.config') -Force | |||
| Assert-ReleaseLayout -ReleasePath $stagingRoot | |||
| if ($RunMigrations) { | |||
| $migrationScript = Join-Path $stagingRoot 'scripts\runMigrations.vbs' | |||
| if (-not (Test-Path -LiteralPath $migrationScript -PathType Leaf)) { throw "Migration script not found: $migrationScript" } | |||
| Write-Warning 'Running migrations by explicit request; IIS rollback cannot undo data changes.' | |||
| Push-Location $stagingRoot | |||
| try { | |||
| & cscript.exe //nologo $migrationScript up | |||
| if ($LASTEXITCODE -ne 0) { throw "Migration command exited with code $LASTEXITCODE" } | |||
| } finally { Pop-Location } | |||
| } | |||
| Move-Item -LiteralPath $stagingRoot -Destination $releaseRoot | |||
| $newPublic = Join-Path $releaseRoot 'public' | |||
| $iisMutationStarted = $true | |||
| if (-not $targetState.Exists) { | |||
| New-WebAppPool -Name $AppPoolName | Out-Null | |||
| $createdPool = $true | |||
| Set-ItemProperty -Path ('IIS:\AppPools\' + $AppPoolName) -Name managedRuntimeVersion -Value '' | |||
| New-Website -Name $SiteName -PhysicalPath $newPublic -ApplicationPool $AppPoolName -IPAddress $BindingIpAddress -Port $BindingPort -HostHeader $HostHeader | Out-Null | |||
| $createdSite = $true | |||
| } else { | |||
| Set-IisRelease -PhysicalPath $newPublic | |||
| } | |||
| Set-WebConfigurationProperty -PSPath 'MACHINE/WEBROOT/APPHOST' -Location $SiteName -Filter 'system.webServer/asp' -Name 'enableParentPaths' -Value $true | |||
| if (-not $targetState.Exists) { | |||
| $poolState = (Get-WebAppPoolState -Name $AppPoolName).Value | |||
| if ($poolState -ne 'Started') { Start-WebAppPool -Name $AppPoolName } | |||
| $siteState = (Get-WebsiteState -Name $SiteName).Value | |||
| if ($siteState -ne 'Started') { Start-Website -Name $SiteName } | |||
| } | |||
| Invoke-SmokeTest | |||
| [ordered]@{ | |||
| siteName = $SiteName; appPoolName = $AppPoolName; currentRelease = $ReleaseId | |||
| currentPhysicalPath = $newPublic; previousPhysicalPath = $targetState.PhysicalPath | |||
| binding = (Get-BindingInformation); packageSha256 = (Get-FileHash -LiteralPath $PackagePath -Algorithm SHA256).Hash | |||
| switchedAtUtc = (Get-Date).ToUniversalTime().ToString('o'); migrationsRun = [bool]$RunMigrations; operation = 'deploy' | |||
| } | ConvertTo-Json | Set-Content -LiteralPath $statePath -Encoding UTF8 | |||
| $protectedPaths = @($newPublic, $targetState.PhysicalPath) | |||
| $oldReleases = Get-ChildItem -LiteralPath $releasesRoot -Directory | | |||
| Where-Object { $_.Name -notlike '*.staging' } | | |||
| Sort-Object LastWriteTimeUtc -Descending | | |||
| Select-Object -Skip $KeepReleases | |||
| foreach ($oldRelease in $oldReleases) { | |||
| $oldPublic = Join-Path $oldRelease.FullName 'public' | |||
| if ($protectedPaths -notcontains $oldPublic) { Write-Step ('Retention candidate (not deleted): ' + $oldRelease.FullName) } | |||
| } | |||
| Write-Step "Deployment complete: $ReleaseId" | |||
| } catch { | |||
| $failure = $_ | |||
| if ($iisMutationStarted) { | |||
| if ($createdSite -and (Get-Website -Name $SiteName -ErrorAction SilentlyContinue)) { | |||
| Write-Warning "Removing site created by this invocation: $SiteName" | |||
| Remove-Website -Name $SiteName | |||
| } | |||
| if ($createdPool -and (Test-Path -LiteralPath ('IIS:\AppPools\' + $AppPoolName))) { | |||
| Write-Warning "Removing app pool created by this invocation: $AppPoolName" | |||
| Remove-WebAppPool -Name $AppPoolName | |||
| } | |||
| if ($targetState.Exists) { | |||
| Write-Warning 'Restoring the prior dedicated target state.' | |||
| Restore-ExistingTarget -TargetState $targetState | |||
| } | |||
| } | |||
| if ($createdSharedConfig -and (Test-Path -LiteralPath $sharedConfig -PathType Leaf)) { | |||
| Write-Warning 'Removing shared configuration initialized by this failed invocation.' | |||
| Remove-Item -LiteralPath $sharedConfig -Force | |||
| } | |||
| if (Test-Path -LiteralPath $stagingRoot) { Write-Warning "Incomplete staging retained for inspection: $stagingRoot" } | |||
| throw $failure | |||
| } | |||
| @@ -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.