Diff -- /var/www/vhosts/3dshawn.com/admin.3dshawn.com/MODS/DBConnect.pm

O Operator
Diff

/var/www/vhosts/3dshawn.com/admin.3dshawn.com/MODS/DBConnect.pm

added on local at 2026-07-10 15:12:08

Added
+278
lines
Removed
-0
lines
Context
0
unchanged
Blobs
from
to 0215813bf347
Restore this content →
Unified diff
Naive LCS-based line diff. Additions in emerald, deletions in rose. Both sides decompressed live from BLOB_STORE.
1package MODS::DBConnect;
2#======================================================================
3# Meta-Admin -- MySQL connection wrapper around DBI.
4#
5# One canonical body across the entire portfolio (7 sister sites +
6# Meta-Admin). Only the credentials block below and the on-disk error
7# log path in error() differ per site.
8#
9# Public API (all methods take $dbh as first non-self arg):
10# $dbh = $db->db_connect -- open a handle to the default DB
11# $db->db_disconnect($dbh) -- close a handle
12# $db->set_session_timezone($dbh, $tz) -- SET time_zone = ... (IANA name or +HH:MM)
13# $hashref = $db->db_readwrite($dbh, $sql, __FILE__, __LINE__)
14# -- run any single-row statement;
15# on SELECT/SHOW/EXPLAIN returns the
16# first row hashref; hashref also
17# carries {mysql_insertid, rows_affected}
18# @rows = $db->db_readwrite_multiple($dbh, $sql, __FILE__, __LINE__)
19# -- returns list (or arrayref in scalar)
20# $sth = $db->db_query($dbh, $sql, @binds)
21# -- placeholder-based helper for
22# user-supplied inputs
23# $bool = $db->ping($dbh) -- SELECT 1 liveness check
24# $csv = $db->quote_list($dbh, \@vals)-- safe "IN (a,b,c)" builder
25# $code = MODS::DBConnect::generate($n)-- random alphanumeric of length $n
26#
27# On any statement failure db_readwrite/_multiple call error() which
28# writes a structured entry to the on-disk log AND prints a marker to
29# STDERR AND exits. That's the "strict canary" behavior -- bad SQL kills
30# the request loud instead of swallowing quietly. Debuggable > silent.
31#======================================================================
32
33# --- Credentials (only block that differs per site) ------------------
34my $default_db_host = 'localhost';
35my $default_db_name = 'admin3dshawn';
36my $default_db_login = 'metaadmin';
37my $default_db_password = 'Sh@wn135';
38my $default_db_port = '3306';
39# ---------------------------------------------------------------------
40
41use strict;
42use warnings;
43use DBI;
44
45# On-disk error log for structured DBI failures. Per-site path.
46my $DB_ERROR_LOG = '/var/www/vhosts/3dshawn.com/admin.3dshawn.com/MODS/DB_ERRORS.log';
47
48sub new {
49 my ($class, %args) = @_;
50 return bless({}, $class);
51}
52
53#---------------------------------------------------------------------
54# db_connect -- open a DBI handle to the default DB. Applies the
55# viewer's IANA time_zone if MODS::Login has cached one, so every
56# TIMESTAMP-reading query returns values in the viewer's local time.
57# Explicit connect flags silence DBI's default warn-to-STDERR behavior
58# (we handle errors ourselves via error()).
59#---------------------------------------------------------------------
60sub db_connect {
61 my $self = shift;
62 my $dsn = "DBI:mysql:$default_db_name:$default_db_host:$default_db_port";
63 my $dbh = DBI->connect($dsn, $default_db_login, $default_db_password, {
64 PrintError => 0, # silence bare DBI warnings to STDERR
65 RaiseError => 0, # we handle errors via error()
66 AutoCommit => 1,
67 mysql_connect_timeout => 5, # fail fast on wedged MySQL
68 mysql_enable_utf8mb4 => 1, # emoji + international UTF-8 support
69 });
70 return undef unless $dbh;
71
72 # Session-level UTF-8 (charset + collation). Belt-and-suspenders
73 # with mysql_enable_utf8mb4 above -- some hosts default to latin1.
74 eval { $dbh->do("SET NAMES utf8mb4") };
75
76 # Apply the viewer's IANA timezone if MODS::Login::login_verify has
77 # cached one. When no user is signed in yet, MariaDB keeps SYSTEM tz.
78 if (defined $MODS::Login::CURRENT_USER_TZ && length $MODS::Login::CURRENT_USER_TZ) {
79 my $tz = $MODS::Login::CURRENT_USER_TZ;
80 $tz =~ s/[^A-Za-z0-9_+\-:\/]//g;
81 if (length $tz) {
82 my $ok = eval { $dbh->do("SET time_zone = " . $dbh->quote($tz)) };
83 if (!$ok || $@) {
84 # MariaDB rejects named zones if mysql.time_zone tables
85 # are not loaded. Fall back to UTC silently rather than 500.
86 eval { $dbh->do("SET time_zone = '+00:00'") };
87 }
88 }
89 }
90
91 return $dbh;
92}
93
94#---------------------------------------------------------------------
95# set_session_timezone($dbh, $tz) -- change tz mid-request. Rare;
96# db_connect picks it up automatically from MODS::Login.
97#---------------------------------------------------------------------
98sub set_session_timezone {
99 my ($self, $dbh, $tz) = @_;
100 return unless $dbh;
101 $tz = 'UTC' unless defined $tz && length $tz;
102 $tz =~ s/[^A-Za-z0-9_+\-:\/]//g;
103 $tz = 'UTC' unless length $tz;
104 my $ok = eval { $dbh->do("SET time_zone = " . $dbh->quote($tz)) };
105 if (!$ok || $@) {
106 eval { $dbh->do("SET time_zone = '+00:00'") };
107 }
108 return 1;
109}
110
111#---------------------------------------------------------------------
112# db_readwrite -- single-row statement runner. For SELECT/SHOW/EXPLAIN
113# returns the first row as a hashref; for INSERT/UPDATE/DELETE returns
114# an empty hashref decorated with {mysql_insertid, rows_affected}.
115# Any DBI failure calls error() which logs + exits.
116#---------------------------------------------------------------------
117sub db_readwrite {
118 my ($self, $dbh, $sql, $script_name, $error_line, $prevent_looping) = @_;
119 my $data;
120
121 my $sth = $dbh->prepare($sql);
122 unless ($sth) {
123 return error($self, $dbh, $script_name, $error_line, $sql, $prevent_looping);
124 }
125 my $rows_affected = $sth->execute;
126 unless ($rows_affected) {
127 # One retry for transient deadlocks / connection blips.
128 $rows_affected = $sth->execute;
129 }
130 unless ($rows_affected) {
131 return error($self, $dbh, $script_name, $error_line, $sql, $prevent_looping);
132 }
133
134 if ($sql =~ m/^\s*\t*(explain|select|show)/i) {
135 $data = $sth->fetchrow_hashref;
136 }
137 $data->{mysql_insertid} = $sth->{mysql_insertid} if $sth->{mysql_insertid};
138 $data->{rows_affected} = $rows_affected if $rows_affected;
139
140 $sth->finish; # release cursor so db_disconnect stays clean
141 return $data;
142}
143
144#---------------------------------------------------------------------
145# db_readwrite_multiple -- multi-row statement runner. Returns list in
146# list context, arrayref in scalar. On non-SELECT/SHOW/EXPLAIN returns
147# empty (the run still executed for its side effects).
148#---------------------------------------------------------------------
149sub db_readwrite_multiple {
150 my ($self, $dbh, $sql, $script_name, $error_line, $nospaces) = @_;
151 my @data;
152
153 my $sth = $dbh->prepare($sql);
154 unless ($sth) {
155 return error($self, $dbh, $script_name, $error_line, $sql);
156 }
157 unless ($sth->execute) {
158 return error($self, $dbh, $script_name, $error_line, $sql);
159 }
160 if ($sql =~ m/^\s*\t*(explain|select|show)/i) {
161 while (my $row = $sth->fetchrow_hashref) { push @data, $row; }
162 }
163 $sth->finish; # explicit finish belt-and-suspenders
164 return wantarray ? @data : \@data;
165}
166
167#---------------------------------------------------------------------
168# db_query($dbh, $sql, @binds) -- placeholder-based statement helper.
169# Use this whenever any part of the SQL comes from user input; the
170# ?-placeholder path is safer than $dbh->quote interpolation because
171# it defers escaping to DBI's own driver-level routines.
172#
173# Returns the statement handle so callers can iterate however they
174# want (fetchrow_hashref / fetchall_arrayref / rows). The caller MUST
175# call $sth->finish (or exhaust the cursor) before db_disconnect.
176#
177# Example:
178# my $sth = $db->db_query($dbh,
179# "SELECT id, email FROM users WHERE created_at >= ? AND role = ?",
180# $start_date, $role);
181# while (my $r = $sth->fetchrow_hashref) { ... }
182# $sth->finish;
183#---------------------------------------------------------------------
184sub db_query {
185 my ($self, $dbh, $sql, @binds) = @_;
186 my $sth = $dbh->prepare($sql) or return undef;
187 return undef unless $sth->execute(@binds);
188 return $sth;
189}
190
191#---------------------------------------------------------------------
192# ping($dbh) -- liveness check. Cheap SELECT 1. Returns 1/0.
193# Useful for admin_maintenance.cgi and long-running scripts.
194#---------------------------------------------------------------------
195sub ping {
196 my ($self, $dbh) = @_;
197 return 0 unless $dbh;
198 my $r = eval { $dbh->selectrow_array("SELECT 1") };
199 return ($r && !$@) ? 1 : 0;
200}
201
202#---------------------------------------------------------------------
203# quote_list($dbh, \@values) -- build a safely quoted comma-list for
204# an IN (...) clause. Empty list returns "''" (never matches).
205#
206# Example:
207# my $csv = $db->quote_list($dbh, \@user_ids);
208# my $sql = "SELECT * FROM orders WHERE user_id IN ($csv)";
209#---------------------------------------------------------------------
210sub quote_list {
211 my ($self, $dbh, $vals) = @_;
212 return "''" unless $vals && ref($vals) eq 'ARRAY' && @$vals;
213 return join(',', map { $dbh->quote($_) } @$vals);
214}
215
216sub db_disconnect {
217 my ($self, $dbh) = @_;
218 return unless $dbh;
219 eval { $dbh->disconnect };
220 return 1;
221}
222
223#---------------------------------------------------------------------
224# generate($len) -- random alphanumeric code of $len characters.
225# Kept here for back-compat with legacy callers that pulled it via
226# MODS::DBConnect::generate. Not a DB function per se.
227#---------------------------------------------------------------------
228sub generate {
229 my $code_length = shift;
230 my $code = '';
231 my @chars = ('a'..'z','A'..'Z','0'..'9');
232 for (1..$code_length) { $code .= $chars[rand @chars]; }
233 return $code;
234}
235
236#---------------------------------------------------------------------
237# error -- called by db_readwrite / _multiple on DBI failure.
238# Writes a structured entry to the on-disk log, mirrors a one-liner
239# to STDERR (Apache error_log), prints any extra @_ args to STDOUT,
240# then exit. That "print + exit" is intentional -- surfaces bugs
241# loud instead of leaving callers to work with undef in silence.
242#---------------------------------------------------------------------
243sub error {
244 my ($self, $dbh, $script_name, $error_line, $application_sql, $prevent_looping) = @_;
245
246 my $unique_id = generate(15) . '_' . time();
247 my $ltime = localtime();
248
249 my $dbi_err = '';
250 if (ref($dbh) && $dbh->can('errstr')) {
251 $dbi_err = $dbh->errstr // '';
252 }
253 $dbi_err ||= $DBI::errstr // '';
254 $dbi_err = '(no DBI error reported)' unless length $dbi_err;
255
256 if (open(my $log_fh, '>>', $DB_ERROR_LOG)) {
257 print $log_fh qq~----- UNIQUE ID:($unique_id) -----\n~;
258 print $log_fh qq~Date: $ltime\n~;
259 print $log_fh qq~File: $script_name\n~;
260 print $log_fh qq~Line: $error_line\n~;
261 print $log_fh qq~DBI: $dbi_err\n~;
262 print $log_fh qq~SQL:\n$application_sql\n\n~;
263 close $log_fh;
264 }
265
266 # Mirror a one-line summary to the Apache error log via STDERR.
267 my $sql_copy = $application_sql;
268 $sql_copy =~ s/\s+/ /g;
269 $sql_copy =~ s/\n$//g;
270 print STDERR qq~-----DB_MODULE_ERROR----- UNIQUE ID:($unique_id) LINE:($error_line) FILE:($script_name) SQL:($sql_copy)\n~;
271
272 # Legacy: any extra args passed to error() are printed. Historical
273 # callers occasionally pass a user-facing error message here.
274 print qq~@_~;
275 exit;
276}
277
2781;