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
+0
lines
Removed
-0
lines
Context
278
unchanged
Blobs
from 0215813bf347
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.
11package MODS::DBConnect;
22#======================================================================
33# Meta-Admin -- MySQL connection wrapper around DBI.
44#
55# One canonical body across the entire portfolio (7 sister sites +
66# Meta-Admin). Only the credentials block below and the on-disk error
77# log path in error() differ per site.
88#
99# Public API (all methods take $dbh as first non-self arg):
1010# $dbh = $db->db_connect -- open a handle to the default DB
1111# $db->db_disconnect($dbh) -- close a handle
1212# $db->set_session_timezone($dbh, $tz) -- SET time_zone = ... (IANA name or +HH:MM)
1313# $hashref = $db->db_readwrite($dbh, $sql, __FILE__, __LINE__)
1414# -- run any single-row statement;
1515# on SELECT/SHOW/EXPLAIN returns the
1616# first row hashref; hashref also
1717# carries {mysql_insertid, rows_affected}
1818# @rows = $db->db_readwrite_multiple($dbh, $sql, __FILE__, __LINE__)
1919# -- returns list (or arrayref in scalar)
2020# $sth = $db->db_query($dbh, $sql, @binds)
2121# -- placeholder-based helper for
2222# user-supplied inputs
2323# $bool = $db->ping($dbh) -- SELECT 1 liveness check
2424# $csv = $db->quote_list($dbh, \@vals)-- safe "IN (a,b,c)" builder
2525# $code = MODS::DBConnect::generate($n)-- random alphanumeric of length $n
2626#
2727# On any statement failure db_readwrite/_multiple call error() which
2828# writes a structured entry to the on-disk log AND prints a marker to
2929# STDERR AND exits. That's the "strict canary" behavior -- bad SQL kills
3030# the request loud instead of swallowing quietly. Debuggable > silent.
3131#======================================================================
3232
3333# --- Credentials (only block that differs per site) ------------------
3434my $default_db_host = 'localhost';
3535my $default_db_name = 'admin3dshawn';
3636my $default_db_login = 'metaadmin';
3737my $default_db_password = 'Sh@wn135';
3838my $default_db_port = '3306';
3939# ---------------------------------------------------------------------
4040
4141use strict;
4242use warnings;
4343use DBI;
4444
4545# On-disk error log for structured DBI failures. Per-site path.
4646my $DB_ERROR_LOG = '/var/www/vhosts/3dshawn.com/admin.3dshawn.com/MODS/DB_ERRORS.log';
4747
4848sub new {
4949 my ($class, %args) = @_;
5050 return bless({}, $class);
5151}
5252
5353#---------------------------------------------------------------------
5454# db_connect -- open a DBI handle to the default DB. Applies the
5555# viewer's IANA time_zone if MODS::Login has cached one, so every
5656# TIMESTAMP-reading query returns values in the viewer's local time.
5757# Explicit connect flags silence DBI's default warn-to-STDERR behavior
5858# (we handle errors ourselves via error()).
5959#---------------------------------------------------------------------
6060sub db_connect {
6161 my $self = shift;
6262 my $dsn = "DBI:mysql:$default_db_name:$default_db_host:$default_db_port";
6363 my $dbh = DBI->connect($dsn, $default_db_login, $default_db_password, {
6464 PrintError => 0, # silence bare DBI warnings to STDERR
6565 RaiseError => 0, # we handle errors via error()
6666 AutoCommit => 1,
6767 mysql_connect_timeout => 5, # fail fast on wedged MySQL
6868 mysql_enable_utf8mb4 => 1, # emoji + international UTF-8 support
6969 });
7070 return undef unless $dbh;
7171
7272 # Session-level UTF-8 (charset + collation). Belt-and-suspenders
7373 # with mysql_enable_utf8mb4 above -- some hosts default to latin1.
7474 eval { $dbh->do("SET NAMES utf8mb4") };
7575
7676 # Apply the viewer's IANA timezone if MODS::Login::login_verify has
7777 # cached one. When no user is signed in yet, MariaDB keeps SYSTEM tz.
7878 if (defined $MODS::Login::CURRENT_USER_TZ && length $MODS::Login::CURRENT_USER_TZ) {
7979 my $tz = $MODS::Login::CURRENT_USER_TZ;
8080 $tz =~ s/[^A-Za-z0-9_+\-:\/]//g;
8181 if (length $tz) {
8282 my $ok = eval { $dbh->do("SET time_zone = " . $dbh->quote($tz)) };
8383 if (!$ok || $@) {
8484 # MariaDB rejects named zones if mysql.time_zone tables
8585 # are not loaded. Fall back to UTC silently rather than 500.
8686 eval { $dbh->do("SET time_zone = '+00:00'") };
8787 }
8888 }
8989 }
9090
9191 return $dbh;
9292}
9393
9494#---------------------------------------------------------------------
9595# set_session_timezone($dbh, $tz) -- change tz mid-request. Rare;
9696# db_connect picks it up automatically from MODS::Login.
9797#---------------------------------------------------------------------
9898sub set_session_timezone {
9999 my ($self, $dbh, $tz) = @_;
100100 return unless $dbh;
101101 $tz = 'UTC' unless defined $tz && length $tz;
102102 $tz =~ s/[^A-Za-z0-9_+\-:\/]//g;
103103 $tz = 'UTC' unless length $tz;
104104 my $ok = eval { $dbh->do("SET time_zone = " . $dbh->quote($tz)) };
105105 if (!$ok || $@) {
106106 eval { $dbh->do("SET time_zone = '+00:00'") };
107107 }
108108 return 1;
109109}
110110
111111#---------------------------------------------------------------------
112112# db_readwrite -- single-row statement runner. For SELECT/SHOW/EXPLAIN
113113# returns the first row as a hashref; for INSERT/UPDATE/DELETE returns
114114# an empty hashref decorated with {mysql_insertid, rows_affected}.
115115# Any DBI failure calls error() which logs + exits.
116116#---------------------------------------------------------------------
117117sub db_readwrite {
118118 my ($self, $dbh, $sql, $script_name, $error_line, $prevent_looping) = @_;
119119 my $data;
120120
121121 my $sth = $dbh->prepare($sql);
122122 unless ($sth) {
123123 return error($self, $dbh, $script_name, $error_line, $sql, $prevent_looping);
124124 }
125125 my $rows_affected = $sth->execute;
126126 unless ($rows_affected) {
127127 # One retry for transient deadlocks / connection blips.
128128 $rows_affected = $sth->execute;
129129 }
130130 unless ($rows_affected) {
131131 return error($self, $dbh, $script_name, $error_line, $sql, $prevent_looping);
132132 }
133133
134134 if ($sql =~ m/^\s*\t*(explain|select|show)/i) {
135135 $data = $sth->fetchrow_hashref;
136136 }
137137 $data->{mysql_insertid} = $sth->{mysql_insertid} if $sth->{mysql_insertid};
138138 $data->{rows_affected} = $rows_affected if $rows_affected;
139139
140140 $sth->finish; # release cursor so db_disconnect stays clean
141141 return $data;
142142}
143143
144144#---------------------------------------------------------------------
145145# db_readwrite_multiple -- multi-row statement runner. Returns list in
146146# list context, arrayref in scalar. On non-SELECT/SHOW/EXPLAIN returns
147147# empty (the run still executed for its side effects).
148148#---------------------------------------------------------------------
149149sub db_readwrite_multiple {
150150 my ($self, $dbh, $sql, $script_name, $error_line, $nospaces) = @_;
151151 my @data;
152152
153153 my $sth = $dbh->prepare($sql);
154154 unless ($sth) {
155155 return error($self, $dbh, $script_name, $error_line, $sql);
156156 }
157157 unless ($sth->execute) {
158158 return error($self, $dbh, $script_name, $error_line, $sql);
159159 }
160160 if ($sql =~ m/^\s*\t*(explain|select|show)/i) {
161161 while (my $row = $sth->fetchrow_hashref) { push @data, $row; }
162162 }
163163 $sth->finish; # explicit finish belt-and-suspenders
164164 return wantarray ? @data : \@data;
165165}
166166
167167#---------------------------------------------------------------------
168168# db_query($dbh, $sql, @binds) -- placeholder-based statement helper.
169169# Use this whenever any part of the SQL comes from user input; the
170170# ?-placeholder path is safer than $dbh->quote interpolation because
171171# it defers escaping to DBI's own driver-level routines.
172172#
173173# Returns the statement handle so callers can iterate however they
174174# want (fetchrow_hashref / fetchall_arrayref / rows). The caller MUST
175175# call $sth->finish (or exhaust the cursor) before db_disconnect.
176176#
177177# Example:
178178# my $sth = $db->db_query($dbh,
179179# "SELECT id, email FROM users WHERE created_at >= ? AND role = ?",
180180# $start_date, $role);
181181# while (my $r = $sth->fetchrow_hashref) { ... }
182182# $sth->finish;
183183#---------------------------------------------------------------------
184184sub db_query {
185185 my ($self, $dbh, $sql, @binds) = @_;
186186 my $sth = $dbh->prepare($sql) or return undef;
187187 return undef unless $sth->execute(@binds);
188188 return $sth;
189189}
190190
191191#---------------------------------------------------------------------
192192# ping($dbh) -- liveness check. Cheap SELECT 1. Returns 1/0.
193193# Useful for admin_maintenance.cgi and long-running scripts.
194194#---------------------------------------------------------------------
195195sub ping {
196196 my ($self, $dbh) = @_;
197197 return 0 unless $dbh;
198198 my $r = eval { $dbh->selectrow_array("SELECT 1") };
199199 return ($r && !$@) ? 1 : 0;
200200}
201201
202202#---------------------------------------------------------------------
203203# quote_list($dbh, \@values) -- build a safely quoted comma-list for
204204# an IN (...) clause. Empty list returns "''" (never matches).
205205#
206206# Example:
207207# my $csv = $db->quote_list($dbh, \@user_ids);
208208# my $sql = "SELECT * FROM orders WHERE user_id IN ($csv)";
209209#---------------------------------------------------------------------
210210sub quote_list {
211211 my ($self, $dbh, $vals) = @_;
212212 return "''" unless $vals && ref($vals) eq 'ARRAY' && @$vals;
213213 return join(',', map { $dbh->quote($_) } @$vals);
214214}
215215
216216sub db_disconnect {
217217 my ($self, $dbh) = @_;
218218 return unless $dbh;
219219 eval { $dbh->disconnect };
220220 return 1;
221221}
222222
223223#---------------------------------------------------------------------
224224# generate($len) -- random alphanumeric code of $len characters.
225225# Kept here for back-compat with legacy callers that pulled it via
226226# MODS::DBConnect::generate. Not a DB function per se.
227227#---------------------------------------------------------------------
228228sub generate {
229229 my $code_length = shift;
230230 my $code = '';
231231 my @chars = ('a'..'z','A'..'Z','0'..'9');
232232 for (1..$code_length) { $code .= $chars[rand @chars]; }
233233 return $code;
234234}
235235
236236#---------------------------------------------------------------------
237237# error -- called by db_readwrite / _multiple on DBI failure.
238238# Writes a structured entry to the on-disk log, mirrors a one-liner
239239# to STDERR (Apache error_log), prints any extra @_ args to STDOUT,
240240# then exit. That "print + exit" is intentional -- surfaces bugs
241241# loud instead of leaving callers to work with undef in silence.
242242#---------------------------------------------------------------------
243243sub error {
244244 my ($self, $dbh, $script_name, $error_line, $application_sql, $prevent_looping) = @_;
245245
246246 my $unique_id = generate(15) . '_' . time();
247247 my $ltime = localtime();
248248
249249 my $dbi_err = '';
250250 if (ref($dbh) && $dbh->can('errstr')) {
251251 $dbi_err = $dbh->errstr // '';
252252 }
253253 $dbi_err ||= $DBI::errstr // '';
254254 $dbi_err = '(no DBI error reported)' unless length $dbi_err;
255255
256256 if (open(my $log_fh, '>>', $DB_ERROR_LOG)) {
257257 print $log_fh qq~----- UNIQUE ID:($unique_id) -----\n~;
258258 print $log_fh qq~Date: $ltime\n~;
259259 print $log_fh qq~File: $script_name\n~;
260260 print $log_fh qq~Line: $error_line\n~;
261261 print $log_fh qq~DBI: $dbi_err\n~;
262262 print $log_fh qq~SQL:\n$application_sql\n\n~;
263263 close $log_fh;
264264 }
265265
266266 # Mirror a one-line summary to the Apache error log via STDERR.
267267 my $sql_copy = $application_sql;
268268 $sql_copy =~ s/\s+/ /g;
269269 $sql_copy =~ s/\n$//g;
270270 print STDERR qq~-----DB_MODULE_ERROR----- UNIQUE ID:($unique_id) LINE:($error_line) FILE:($script_name) SQL:($sql_copy)\n~;
271271
272272 # Legacy: any extra args passed to error() are printed. Historical
273273 # callers occasionally pass a user-facing error message here.
274274 print qq~@_~;
275275 exit;
276276}
277277
2782781;