Pm/Bc_sql.pm
Copying Source is Forbidden
3819 lines of code
1
package Bc_sql;
2
3
#/
4
# a module for manipulating an SQLite DB
5
#
6
# usage: use Pm::Bc_sql qw(...);
7
#
8
# oh wow! what a fantastic idea!
9
# each user gets their own database file!
10
# that database file, perhaps, can be password
11
# protected, using the user's password!
12
# i'll investigate that idea with the current
13
# setup. DBI is for sqlite.
14
#/
15
16
binmode(STDIN, ":utf8");
17
binmode(STDOUT, ":utf8");
18
19
########################
20
use strict;
21
use warnings;
22
use Exporter;
23
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK @EXPORT_TAGS);
24
use CGI::Carp qw(fatalsToBrowser);
25
use HTML::Restrict;
26
use DBI;
27
########################
28
29
30
31
########################
32
our $VERSION = 1.00;
33
our @ISA = qw(Exporter);
34
our @EXPORT_TAGS = qw(DEFAULT=>[qw(
35
sql_connect
36
sql_execute
37
user_exists
38
39
$QUERY_PAGE
40
$QUERY_UID
41
$CONSTANTS_LOADED
42
%CONSTANTS
43
$ERRORS_LOADED
44
@ERRORS
45
%ERRORS
46
$LOGGEDIN
47
$SITE_NAME
48
$DB
49
)]);
50
our @EXPORT = qw(
51
sql_execute
52
get_constant
53
get_config
54
user_exists
55
56
$QUERY_PAGE
57
$QUERY_UID
58
$CONSTANTS_LOADED
59
%CONSTANTS
60
$ERRORS_LOADED
61
@ERRORS
62
$LOGGEDIN
63
$SITE_NAME
64
$DB
65
);
66
67
our @EXPORT_OK = qw(
68
_tests
69
70
sql_connect
71
sql_create_perchie
72
sql_create_random_user
73
sql_create_random_user_updated
74
sql_db_user_reset
75
sql_db_valid
76
sql_execute
77
sql_execute_bound
78
sql_execute_multi
79
sql_sanitize_db_nicknames
80
81
get_about_page
82
get_bans
83
get_beta_users
84
get_body_asWord
85
get_cities
86
get_city_id
87
get_city_name
88
get_config
89
get_config_asWord
90
get_constant
91
get_constants
92
get_constants_asHash
93
get_country_cities
94
get_country_id
95
get_country_id_byName
96
get_country_name
97
get_countries
98
get_data_policy_page
99
get_debug_users
100
get_default_theme
101
get_error
102
get_error_message
103
get_errors
104
get_errors_asHash
105
get_eye_clr_asWord
106
get_flag_data
107
get_flags
108
get_gender_asWord
109
get_hair_clr_asWord
110
get_height_asWord
111
get_help_page
112
get_home_page
113
get_latest_memberships
114
get_location
115
get_login
116
get_membership_type
117
get_navbar
118
get_new_theme_data
119
get_orientation_asWord
120
get_photo_desc
121
get_photo_name
122
get_phrase
123
get_profile_views_count
124
get_race_asWord
125
get_reason_asWord
126
get_reasons
127
get_security
128
get_security_asWord
129
get_security_asWord_friendly
130
get_security_fromWord
131
get_seeking_asWord
132
get_site_name
133
get_terms_page
134
get_refunds_page
135
get_privacy_page
136
get_legals_page
137
get_theme_data
138
get_theme_purchases
139
get_themes
140
get_top10_fma_counts
141
get_user_count
142
get_users
143
get_users_forDropdowns
144
get_weight_asWord
145
get_zodiac_icon_fn
146
get_zodiacs
147
148
set_config
149
set_constant
150
151
is_flagged
152
is_friend
153
is_debuggerAllowed
154
is_badname
155
156
ban_exists
157
ccid_exists
158
fma_exists
159
gift_exists
160
ipn_exists
161
msg_exists
162
msgid_exists
163
msgs_exist
164
sid_exists
165
theme_exists
166
user_exists
167
168
sql_get_user_stat
169
170
in_maint
171
new_ccid
172
new_msgid
173
new_sid
174
new_tid
175
new_uid
176
177
validate_new_user_data
178
valid_id
179
valid_tid
180
valid_ip
181
valid_config
182
valid_location
183
184
add_points
185
inc_pviews
186
visited
187
num_visitors
188
189
$QUERY_SEARCH_TERMS
190
$QUERY_PAGE
191
$QUERY_UID
192
$ABOUT_PAGE
193
$ACCEPT_PAGE
194
$BLOCKED_PAGE
195
$BROWSE_PAGE
196
$CONTACT_PAGE
197
$FAQ_PAGE
198
$FORGOT_PAGE
199
$FRIENDS_PAGE
200
$HELP_PAGE
201
$LOGIN_PAGE
202
$LOGOUT_PAGE
203
$MAIL_PAGE
204
$MOD_PAGE
205
$PAY_PAGE
206
$PHOTOS_PAGE
207
$PROFILE_PAGE
208
$SEARCH_PAGE
209
$SEARCH_QUERY
210
$SIGNUP_PAGE
211
$STORE_PAGE
212
$TERMS_PAGE
213
$WELCOME_PAGE
214
215
$BEGINNING_OF_TIME
216
$END_OF_TIME
217
$LOGGEDIN
218
$SITE_NAME
219
220
%CONSTANTS
221
$CONSTANTS_LOADED
222
@ERRORS
223
$ERRORS_LOADED
224
225
$DB
226
$curr_db_fn
227
$default_db_fn
228
);
229
########################
230
231
########################
232
# some "constants"
233
########################
234
235
# QUERY_* constants. these are param NAMES
236
our $QUERY_SEARCH_TERMS = "";
237
our $QUERY_PAGE = "";
238
our $QUERY_UID = "";
239
240
# global "constants"
241
our %CONSTANTS;
242
our @ERRORS;
243
our %ERRORS;
244
our $DB;
245
246
# commonly used *_PAGE constants.
247
our $ABOUT_PAGE = "";
248
our $ACCEPT_PAGE = "";
249
our $BLOCKED_PAGE = "";
250
our $BROWSE_PAGE = "";
251
our $CONTACT_PAGE = "";
252
our $FAQ_PAGE = "";
253
our $FORGOT_PAGE = "";
254
our $FRIENDS_PAGE = "";
255
our $HELP_PAGE = "";
256
our $LOGIN_PAGE = "";
257
our $LOGOUT_PAGE = "";
258
our $MAIL_PAGE = "";
259
our $MOD_PAGE = "";
260
our $PAY_PAGE = "";
261
our $PHOTOS_PAGE = "";
262
our $PROFILE_PAGE = "";
263
our $SEARCH_PAGE = "";
264
our $SIGNUP_PAGE = "";
265
our $STATS_PAGE = "";
266
our $STORE_PAGE = "";
267
our $TERMS_PAGE = "";
268
our $WELCOME_PAGE = "";
269
our $CONSTANTS_LOADED = 1;
270
our $ERRORS_LOADED = 1;
271
272
# IMAGE_* constants. these point to files within /images/
273
# none defined yet
274
275
# other, useful constants
276
our $BEGINNING_OF_TIME = "";
277
our $END_OF_TIME = "";
278
our $LOGGEDIN = "";
279
our $SITE_NAME = "";
280
281
use lib "./";
282
use Bc_chef;
283
use Bc_dir;
284
require Security;
285
require Redir;
286
287
our $default_db_fn = Bc_dir::read_text("/var/www/html/dbfn.txt");
288
our $curr_db_fn = $default_db_fn;
289
290
my $DEBUG = 0;
291
292
########################
293
sub sql_connect(;$) {
294
#*
295
# this will connect to a specified db
296
# or a default DB if one is not provided
297
#*
298
my ($db_fn, $db_interface) = @_; # the database filename (optional, defaults to whatever is in "dbfn.txt") & an DB to use (default: SQLite)
299
if (not $db_interface) { $db_interface = "SQLite"; }
300
if (not $db_fn) { $db_fn = $default_db_fn; }
301
my $rv = 0;
302
303
# if the database is already active
304
# assign $DB to $rv
305
# otherwise
306
# disconnect from the current database
307
# connect to the new database
308
# assign $rv to $DB
309
310
if ($DB) {
311
if ($curr_db_fn eq $db_fn) {
312
$rv = $DB;
313
} else {
314
sql_disconnect();
315
$curr_db_fn = $db_fn;
316
317
my $db_handle = DBI->connect("DBI:$db_interface:dbname=$db_fn", "", "", { PrintWarn => 0, RaiseError => 0, sqlite_unicode => 1 });
318
319
if ($db_handle) {
320
if (not $db_handle->{'sqlite_unicode'}) { $db_handle->{'sqlite_unicode'} = 1; }
321
if (not $db_handle->{'AutoCommit'}) { $db_handle->{'AutoCommit'} = 1; }
322
$rv = $db_handle;
323
$DB = $db_handle;
324
}
325
}
326
} else {
327
my $db_handle = DBI->connect("DBI:$db_interface:dbname=$db_fn", "", "", { PrintWarn => 0, RaiseError => 0 });
328
329
if ($db_handle) {
330
$db_handle->{'sqlite_unicode'} = 1;
331
$db_handle->{'AutoCommit'} = 1;
332
$rv = $db_handle;
333
$DB = $db_handle;
334
}
335
}
336
337
return $rv; # 0 or a reference to a DBI object
338
#usage: my $dbh = sql_connect("mydb.db");
339
}
340
341
########################
342
sub sql_disconnect() {
343
#*
344
# this will commit any remaining changes to and disconnect from
345
# the database. unless you have enabled autocommit, please
346
# be sure this gets executed at the end of your sequence!
347
# you are always welcome to "commit" anytime you like, of course.
348
#*
349
#@_; # (no parameters)
350
351
# first, we will "commit" the changes to the db, if AutoCommit is disabled
352
if (not $DB->{AutoCommit}) { $DB->commit(); }
353
354
# and then disconnect from the db
355
$DB->disconnect();
356
$curr_db_fn = "";
357
358
return undef; # always <i>undef</i>
359
#usage: sql_disconnect();
360
}
361
362
########################
363
sub sql_execute($;$$) {
364
#*
365
# runs an SQL statement on the supplied db.<br>
366
367
# db must be connected, and <a href='#sql_disconnect'>sql_disconnect</a> to
368
# commit changes IF autocommit is disabled.<br>
369
370
# <br>when successful, will return:
371
# - an array ref, or a hash ref depending on the # of results (can be overridden)
372
# - otherwise, returns 0
373
374
# <br><div class='centered error' style='text-align: left;'> - this function does not and will NOT "sanitize" your query!
375
# - this function is SLOW when executed repeatedly!
376
# - <i>$noHashRef</i> returns an empty array when $DB->prepare($sql) fails
377
# when query contains invalid table/field name(s))</div><br>
378
#*
379
my ($sql, $debug_caller, $asArrayRef) = @_; # an SQL statement && for debug purposes (optional) && assign <i>1</i> to always return array ref (optional)
380
my $rv = 0;
381
382
my ($p, $f, $l) = caller;
383
my $c = "line $l of module $p\:\:$f";
384
385
if ($DB) {
386
my $prept = $DB->prepare($sql) or die $DB->errstr . " (sql=\"$sql\")" . "\nDev Msg: " . $debug_caller . "\n" . "DBN: " . $curr_db_fn;
387
if (not $prept) {
388
my $msg = "db prepare failed (sql_execute";
389
if ($debug_caller) { $msg .= "->$debug_caller"; }
390
$msg .= ") (DB filename: $curr_db_fn): " . $DB->errstr;
391
if ($asArrayRef) {
392
my @why_didnt_slash_open_and_close_parenthesis_work = ();
393
# cuz i'm not doing this right?
394
$rv = \@why_didnt_slash_open_and_close_parenthesis_work;
395
} else {
396
$rv = 0; # 0 when sql statement prepare failed (for any reason)
397
# often, but not limited to, it's because of uniqueness conflict(s)
398
# or bad table name or invalid number of fields, or the set values are
399
# invalid. eg: "set values(NULL, code='123')", when it should just be
400
# "set values(NULL, '123')"
401
}
402
#die $msg;
403
}
404
else {
405
if ($sql =~ /^insert |^update |^delete |^set /i) {
406
if (not $debug_caller) { $debug_caller = $c; }
407
if ($DEBUG) {
408
$rv = $DB->do($sql) or die $DB->errstr . "->$debug_caller";
409
}
410
else {
411
$rv = $DB->do($sql) or print Redir::error_redir(Bc_misc::referrer(), "$debug_caller->DB Error: " . $DB->errstr);
412
}
413
414
if ($rv eq "0E0") { $rv = 0; } # no rows were affected!
415
}
416
else {
417
$prept->execute();
418
# now, grab all the results from the query, and dump them into an array as hash references to each "hit"
419
my @arr = ();
420
while (my $row = $prept->fetchrow_hashref) { push @arr, $row; }
421
422
if ($asArrayRef) {
423
$rv = \@arr; # an array reference, when requested (can be a zero element array)
424
} else {
425
if (@arr == 1 and ref $arr[0] eq "HASH") {
426
$rv = $arr[0]; # return a hash reference when there is only one result
427
} else {
428
$rv = \@arr; # an array reference (can be a zero element array)
429
}
430
}
431
}
432
}
433
}
434
435
return $rv; # see description
436
#usage: my $rv = sql_execute($sql, ": generated from myFunction");
437
}
438
439
########################
440
sub get_constant($) {
441
#*
442
# retrieves the value of a specified constant
443
#*
444
my ($name) = @_; # name of constant to retreive
445
my $rv = 0;
446
if (lc($name) eq "seeking") { $name = "styles"; }
447
448
if ($DB) {
449
if (%CONSTANTS) {
450
$rv = $CONSTANTS{$name};
451
} else {
452
my $sql = "select value from constants where name = " . $DB->quote($name);
453
my $const = sql_execute($sql, "Bc_sql.pm::get constant");
454
if ($const ne -1 and $const ne 0) {
455
# would seem logical to write "if ref > 1", but this doesn't give > 1. it only gives 0, -1
456
# or a reference to a hash or an array, or it's a non-referencing scalar
457
# arrays should never get returned by the above code.
458
if (ref $const eq "HASH") {
459
$rv = $const->{value};
460
} elsif (ref $const ne "ARRAY") {
461
$rv = $const; # a scalar
462
}
463
}
464
}
465
}
466
467
if ($name eq "DEBUG_PAYPAL") { $rv -= 1; }
468
469
return $rv; # a scalar
470
#usage: my $const = get_constant("SITE_NAME");
471
}
472
473
########################
474
sub get_constants() {
475
#*
476
# generates an array of hash references to each "constant"
477
# hash key = name of constant. related value of hash element is value of constant
478
#*
479
#@_; # (no parameters)
480
my @rv = ();
481
482
my $ref = sql_execute("select * from constants order by name", "Bc_sql.pm::get constants");
483
if (ref $ref eq "HASH")
484
{ push @rv, $ref; }
485
elsif (ref $ref eq "ARRAY")
486
{ @rv = @$ref; }
487
488
return @rv; # an array of hash references to each constant
489
#usage: my %constants = get_constants();
490
}
491
492
########################
493
sub get_constants_asHash() {
494
#*
495
# generates a hash of constants where
496
# key = name of constant and value = value of constant
497
#*
498
#@_; # (no parameters)
499
my %constants;
500
501
my @consts = get_constants();
502
if (@consts > 0) {
503
foreach my $eHRef (@consts) {
504
my $n = $eHRef->{name};
505
my $v = $eHRef->{value};
506
$constants{$n} = $v;
507
}
508
509
$constants{GOT_LOADED} = 2;
510
} else {
511
$constants{GOT_LOADED} = 1;
512
}
513
514
return %constants; # a hash
515
#usage: my %constants = get_constants_asHash();
516
}
517
518
########################
519
sub get_errors() {
520
#*
521
# generates an array of hash references to each "error"
522
#*
523
#@_; # (no parameters)
524
my $ref = sql_execute("select * from errors order by code", "Bc_sql.pm::get errors");
525
my @rv = ();
526
527
if (ref $ref eq "HASH") {
528
push @rv, $ref;
529
} elsif (ref $ref eq "ARRAY") {
530
@rv = @$ref;
531
}
532
533
return \@rv; # an array of hash references to each error
534
#usage: my @errors = get_errors();
535
}
536
537
########################
538
sub get_errors_asHash() {
539
#*
540
# generates a hash reference of constants where
541
# key = name of constant and value = value of constant
542
# !this function is not yet complete!
543
#*
544
#@_; # (no parameters)
545
my $errorsArrayRef = sql_execute("select * from errors", "Bc_sql::get errors_asHash", 1);
546
my @arr = ();
547
my $rv = \@arr;
548
549
if (ref $errorsArrayRef eq "ARRAY") {
550
my %errorsHash;
551
foreach my $e (@$errorsArrayRef) {
552
my $name = $e->{name};
553
delete $e->{name};
554
$errorsHash{$name} = $e;
555
}
556
557
$rv = \%errorsHash;
558
}
559
560
return $rv; # nothing, atm
561
#usage: our %ERRORS = get_errors_asHash();
562
}
563
564
########################
565
sub get_error($;$$) {
566
#*
567
# retrieves the code, name, or description of a specified error
568
# or all columns of an error code
569
# $cnd = code/name/description to search for (eg: -1000)
570
# $type = the type of $cnd (eg: c)
571
# $rType = the type of info to return (eg: n)
572
#
573
# an example request would be:
574
# my $err = get_error("-1000", "c", "n");
575
# and $err would now be PAGE_INVALID
576
#
577
# when $rType = "a" or "e", a reference to the data is returned
578
# in the case of "a" - returns hash reference
579
# in the case of "e" - returns array reference of hash references
580
#*
581
my ($cnd, $type, $rType) = @_; # code/name/desc to retrieve && $cnd type (c, n, d) && rVal type (e, a, c, n, d, i)
582
my $rv = 0;
583
my $sql;
584
585
if ($DB) {
586
if (not @ERRORS) {
587
# error constants are loaded
588
if ($rType eq "e") {
589
$rv = \@ERRORS;
590
} else {
591
foreach my $eRef (@ERRORS) {
592
# $eRef is a hash reference
593
594
if ($rType eq "a") {
595
if ($type eq "c") {
596
if ($eRef->{code} eq $cnd) { $rv = $eRef; last; }
597
} elsif ($type eq "n") {
598
if ($eRef->{name} eq $cnd) { $rv = $eRef; last; }
599
} elsif ($type eq "d") {
600
if ($eRef->{desc} eq $cnd) { $rv = $eRef; last; }
601
} elsif ($type eq "i") {
602
if ($eRef->{ID} eq $cnd) { $rv = $eRef; last; }
603
}
604
605
} elsif ($rType eq "c") {
606
607
if ($type eq "c") {
608
if ($eRef->{code} eq $cnd) { $rv = $eRef->{code}; last; }
609
} elsif ($type eq "n") {
610
if ($eRef->{code} eq $cnd) { $rv = $eRef->{name}; last; }
611
} elsif ($type eq "d") {
612
if ($eRef->{code} eq $cnd) { $rv = $eRef->{desc}; last; }
613
} elsif ($type eq "i") {
614
if ($eRef->{code} eq $cnd) { $rv = $eRef->{ID}; last; }
615
}
616
617
} elsif ($rType eq "n") {
618
619
if ($type eq "c") {
620
if ($eRef->{name} eq $cnd) { $rv = $eRef->{code}; last; }
621
} elsif ($type eq "n") {
622
if ($eRef->{name} eq $cnd) { $rv = $eRef->{name}; last; }
623
} elsif ($type eq "d") {
624
if ($eRef->{name} eq $cnd) { $rv = $eRef->{desc}; last; }
625
} elsif ($type eq "i") {
626
if ($eRef->{name} eq $cnd) { $rv = $eRef->{ID}; last; }
627
}
628
629
} elsif ($rType eq "d") {
630
631
if ($type eq "c") {
632
if ($eRef->{desc} eq $cnd) { $rv = $eRef->{code}; last; }
633
} elsif ($type eq "n") {
634
if ($eRef->{desc} eq $cnd) { $rv = $eRef->{name}; last; }
635
} elsif ($type eq "d") {
636
if ($eRef->{desc} eq $cnd) { $rv = $eRef->{desc}; last; }
637
} elsif ($type eq "i") {
638
if ($eRef->{desc} eq $cnd) { $rv = $eRef->{ID}; last; }
639
}
640
641
} elsif ($rType eq "i") {
642
643
if ($type eq "c") {
644
if ($eRef->{ID} eq $cnd) { $rv = $eRef->{code}; last; }
645
} elsif ($type eq "n") {
646
if ($eRef->{ID} eq $cnd) { $rv = $eRef->{name}; last; }
647
} elsif ($type eq "d") {
648
if ($eRef->{ID} eq $cnd) { $rv = $eRef->{desc}; last; }
649
} elsif ($type eq "i") {
650
if ($eRef->{ID} eq $cnd) { $rv = $eRef->{ID}; last; }
651
}
652
653
}
654
}
655
}
656
} else {
657
# error constants are NOT loaded
658
if ($rType eq "e") {
659
$sql = "select * from errors";
660
} else {
661
$sql = "select ";
662
663
if ($rType eq "a") { $sql .= "*"; }
664
elsif ($rType eq "c") { $sql .= "code"; }
665
elsif ($rType eq "n") { $sql .= "name"; }
666
elsif ($rType eq "d") { $sql .= "desc"; }
667
elsif ($rType eq "d") { $sql .= "ID"; }
668
669
$sql .= " from errors where ";
670
671
if ($type eq "c") { $sql .= "code="; }
672
elsif ($type eq "n") { $sql .= "name="; }
673
elsif ($type eq "d") { $sql .= "desc="; }
674
elsif ($type eq "d") { $sql .= "ID="; }
675
676
$sql .= $DB->quote($cnd);
677
}
678
}
679
}
680
681
return $rv; # a scalar
682
#usage: my $e = get_error("NO_DATA", 1);
683
}
684
685
########################
686
sub get_login(;$$$$$) {
687
#*
688
# to get a user ID associated with a "session ID"
689
# this will grab the client cookie, which contains
690
# the session ID. It will then look that up in the
691
# database, and return the associated user ID
692
#*
693
my ($tn, $fn, $cn, $kn, $allfields) = @_; # table name (default = "loggedin") && field name (default = "cookie_data") && cookie name (default = "sesh_id") && hash key name (default = $QUERY_UID) && return hash ref to all fields, not just a single field's value
694
if (not $tn) { $tn = "loggedin"; }
695
if (not $fn) { $fn = "cookie_data"; }
696
if (not $cn) { $cn = "sesh_id"; }
697
if (not $kn) { $kn = "UID"; }
698
if ($allfields) { $kn = "*"; }
699
my $rv = 0;
700
701
if ($DB > 0) {
702
my $sid = Bc_chef::cookie_get($cn);
703
if ($sid) {
704
my $sql = "select $kn from $tn where $fn=" . $DB->quote($sid);
705
my $result = sql_execute($sql, "Bc_sql -> get_login()");
706
if (ref $result eq "HASH") {
707
if ($allfields)
708
{ $rv = $result; } else
709
{ $rv = $result->{$kn}; }
710
}
711
} else {
712
$rv = 0;
713
}
714
} else {
715
$rv = 0;
716
}
717
718
return $rv; # a user's ID (or 0 if $DB error)
719
#usage: my $uid = get_login();
720
}
721
722
#####################################################################################################################
723
# we got the important bits, so
724
# connect to our "constants" database, and populate the variables
725
# i want this block to fail nicely if it can't connect to the db
726
# how?
727
BEGIN {
728
$default_db_fn = Bc_dir::read_text("/var/www/html/dbfn.txt");
729
$curr_db_fn = $default_db_fn;
730
731
$DB = sql_connect();
732
733
if (ref $DB) {
734
$DB->{AutoCommit} = 1;
735
736
if ($DEBUG) {
737
$DB->{RaiseError } = 1;
738
$DB->{PrintError} = 1;
739
} else {
740
$DB->{RaiseError } = 0;
741
$DB->{PrintError} = 0;
742
}
743
}
744
else {
745
die "Database connection failed: $DBI::errstr\n";
746
}
747
748
%CONSTANTS = get_constants_asHash();
749
#@ERRORS = get_errors();
750
#my $terrors = get_errors_asHash();
751
#if (ref $terrors eq "HASH") { %ERRORS = %$terrors; }
752
753
$QUERY_SEARCH_TERMS = get_constant("QUERY_SEARCH_TERMS");
754
755
$QUERY_PAGE = get_constant("QUERY_PAGE");
756
$QUERY_UID = get_constant("QUERY_UID");
757
758
$ABOUT_PAGE = get_constant("ABOUT_PAGE");
759
$ACCEPT_PAGE = get_constant("ACCEPT_PAGE");
760
$BLOCKED_PAGE = get_constant("BLOCKED_PAGE");
761
$BROWSE_PAGE = get_constant("BROWSE_PAGE");
762
$CONTACT_PAGE = get_constant("CONTACT_PAGE");
763
$FAQ_PAGE = get_constant("FAQ_PAGE");
764
$FORGOT_PAGE = get_constant("FORGOT_PAGE");
765
$FRIENDS_PAGE = get_constant("FRIENDS_PAGE");
766
$HELP_PAGE = get_constant("HELP_PAGE");
767
$LOGIN_PAGE = get_constant("LOGIN_PAGE");
768
$LOGOUT_PAGE = get_constant("LOGOUT_PAGE");
769
$MAIL_PAGE = get_constant("MAIL_PAGE");
770
$MOD_PAGE = get_constant("MOD_PAGE");
771
$PAY_PAGE = get_constant("PAY_PAGE");
772
$PHOTOS_PAGE = get_constant("PHOTOS_PAGE");
773
$PROFILE_PAGE = get_constant("PROFILE_PAGE");
774
$SEARCH_PAGE = get_constant("SEARCH_PAGE");
775
$SIGNUP_PAGE = get_constant("SIGNUP_PAGE");
776
$STATS_PAGE = get_constant("STATS_PAGE");
777
$STORE_PAGE = get_constant("STORE_PAGE");
778
$TERMS_PAGE = get_constant("TERMS_PAGE");
779
$WELCOME_PAGE = get_constant("WELCOME_PAGE");
780
781
$BEGINNING_OF_TIME = get_constant("BEGINNING_OF_TIME");
782
$END_OF_TIME = get_constant("END_OF_TIME");
783
$SITE_NAME = get_constant("SITE_NAME");
784
785
$LOGGEDIN = get_login();
786
}
787
#####################################################################################################################
788
789
790
########################################################################
791
########################################################################
792
# these vars are injected into the USER table upon DB Reset
793
# it will be the default password for the site admin, mr. perchie, and
794
# a default pw for test accounts used during debug phase
795
my $DEFAULT_PW_FOR_ADMIN = Security::encrypt(Bc_dir::read_text("./db_pwords/admin.txt"));
796
my $DEFAULT_PW_FOR_PERCHIE = Security::encrypt(Bc_dir::read_text("./db_pwords/perchie.txt"));
797
my $DEFAULT_PW_FOR_USER = Security::encrypt(Bc_dir::read_text("./db_pwords/user.txt"));
798
########################################################################
799
########################################################################
800
801
802
803
804
########################################################################
805
########################################################################
806
###
807
### the following are "sql_" functions
808
###
809
########################################################################
810
########################################################################
811
812
813
########################
814
sub sql_db_valid() {
815
#*
816
# checks if $DB is a hash reference
817
#*
818
#@_; # (no parameters)
819
820
if ($DB !~ /^DBI::db=HASH\(\0x(.)*\)/i) {
821
return 1; # if $DB references a hash
822
} else {
823
return 0; # if $DB does not reference a hash
824
}
825
#usage: if (not sql_db_valid()) { print "not connected to db"; exit 1; }
826
}
827
828
########################
829
sub sql_execute_bound($$) {
830
#*
831
# prepares and executes an SQL statement, using bound parameters
832
# return values will be just like sql_execute(...)
833
# run sql_execute($$) for statements like update, insert, n delete
834
# better still would be to use sql_do_bound($$) instead
835
# !this function is not yet complete
836
# !this function is SLOW when executed repeatedly!
837
#*
838
my ($sql, $valuesRef) = @_; # an sql statement && a reference to a list of values to be bound (ensure order is correct)
839
840
my $prept = $DB->prepare($sql) or die "data access error: " . DBI->errstr;
841
$prept->execute(@$valuesRef);
842
my @arr = ();
843
while (my $row = $prept->fetchrow_hashref) { push @arr, $row; }
844
845
if (@arr eq 1 and ref $arr[0] eq "HASH") {
846
# if the array has only one element, then, it's kinda pointless to give a ref to the array
847
# so instead, let's just give back that hash reference
848
849
return $arr[0]; # a hash reference when there is only one array element
850
} elsif (@arr eq 1 and ref $arr[0] ne "HASH") {
851
# if the array has only one element, and it's not a hash reference (meaning $arr[0] =~ /0e0/i)
852
# then ...
853
@arr = (); # clear the array
854
}
855
856
return \@arr; # an array reference (can be a zero element array)
857
#usage: my $results = sql_execute_bound(\@params, \@values);
858
}
859
860
########################
861
sub sql_execute_multi($;$) {
862
#*
863
# this function is intended to run as fast as we can get it
864
# so we'll see what we can do
865
# will only run <i>insert</i>, <i>delete</i>, and/or <i>update</i> SQL statements on the db.
866
# !this function does not and will NOT "sanitize" your query!
867
#*
868
my ($arrayRef_of_sql_statements, $debug_caller) = @_; # the SQL statements (an array reference) && a msg for debug purposes (optional, see code)
869
my $rv = 1;
870
871
if ($DB and ref $arrayRef_of_sql_statements eq "ARRAY") {
872
my $oldCommit = $DB->{AutoCommit};
873
$DB->{AutoCommit} = 0;
874
foreach my $sql (@$arrayRef_of_sql_statements) {
875
my $prept = $DB->prepare($sql);
876
877
if ($prept and $sql =~ /^insert |update |delete /i) {
878
my $done = $DB->do($sql);
879
if ($done eq "0E0") {
880
# execute failed, so, end this shit
881
$rv = 0;
882
last;
883
}
884
} else {
885
if (not $prept) {
886
my $msg = "db prepare failed (sql_execute";
887
if ($debug_caller) { $msg .= "->$debug_caller"; }
888
$msg .= "): " . DBI->errstr;
889
die $msg;
890
} else {
891
# not an insert, delete, or update command
892
$rv = 0;
893
last;
894
}
895
}
896
}
897
898
$DB->commit();
899
$DB->{AutoCommit} = $oldCommit;
900
} else {
901
$rv = 0;
902
}
903
904
return $rv; # 1 on success, 0 on failure
905
#usage: my $rv = sql_execute_multi(\@sql_statements, "from myFunction, because 1 ne 2");
906
}
907
908
########################
909
sub sql_db_user_reset(;$$) {
910
#*
911
# <div class='error text-align-center'>WARNING<hr>this function <i>will</i> destroy all
912
# of the data stored in the USER table
913
# and rebuilds the Administrator's Account</div>
914
#*
915
916
my ($adminOnly, $testOnly) = @_; # reset only the admin's account && just test, don't commit changes
917
my $sql_delete = "delete from users";
918
my $rv = 0;
919
if ($adminOnly) { $sql_delete .= " where nickname = 'JamRoll'"; }
920
921
if ($testOnly) {
922
$rv = "$sql_delete\n";
923
} else {
924
sql_execute($sql_delete, "Bc_sql.pm::purge user table");
925
my $sql_admin = "insert into users values (1,"; # ID
926
$sql_admin .= "\"JamRoll\","; # nickname
927
$sql_admin .= "\"jamroll1976\@gmail.com\","; #email
928
$sql_admin .= "\"1976-01-19\","; # dob
929
$sql_admin .= "2,"; # show bday
930
$sql_admin .= "\"0.0.0.0\","; # last ip
931
$sql_admin .= "\"$DEFAULT_PW_FOR_ADMIN\","; # password
932
$sql_admin .= "1,"; # race
933
$sql_admin .= "1,"; # gender
934
$sql_admin .= "\"31-1\","; # location
935
$sql_admin .= "1,"; # orientation
936
$sql_admin .= "2,"; # drugs
937
$sql_admin .= "1,"; # wheels
938
$sql_admin .= "1,"; # can_host
939
$sql_admin .= "2,"; # drinker
940
$sql_admin .= "1,"; # smoker
941
$sql_admin .= "1,"; # seeking
942
$sql_admin .= "2,"; # seeking_gender
943
$sql_admin .= "6,"; # erection
944
$sql_admin .= "1,"; # bust
945
$sql_admin .= "2,"; # eye_clr
946
$sql_admin .= "3,"; # hair_clr
947
$sql_admin .= "8,"; # weight
948
$sql_admin .= "8,"; # height
949
$sql_admin .= "3,"; # body
950
$sql_admin .= "\"1976-01-19\","; # enrolled date
951
$sql_admin .= "2,"; # subscriber
952
$sql_admin .= "\"1976-01-19\","; # subscription start date
953
$sql_admin .= "3,"; # subscription type
954
$sql_admin .= "1,"; # CCID
955
$sql_admin .= "2,"; # TID
956
$sql_admin .= "4,"; # security (super admin)
957
$sql_admin .= "\"Default Site Super Admininstrator Account\",";
958
$sql_admin .= "1)"; # banned (1 == not banned)
959
960
my $sql = sql_execute($sql_admin, "Bc_sql.pm::insert into user table");
961
if ($sql) {
962
$rv = 1;
963
}
964
}
965
966
return $rv; # 1 on success or 0 on SQL error, or more when testing
967
#usage: sql_db_user_reset();
968
}
969
970
########################
971
sub sql_create_perchie() {
972
#*
973
# Add nick perchie to db as moderator
974
#*
975
my $rv = 0;
976
977
my $sql_admin = "insert into users values (";
978
$sql_admin .= "2,"; # ID
979
$sql_admin .= "\"Perchie\","; # nickname
980
$sql_admin .= "\"nickperchie\@night-stand.ca\","; #email
981
$sql_admin .= "\"1901-01-01\","; # dob
982
$sql_admin .= "2,"; # show bday
983
$sql_admin .= "\"0.0.0.0\","; # last ip
984
$sql_admin .= "\"$DEFAULT_PW_FOR_PERCHIE\","; # password
985
$sql_admin .= "1,"; # race
986
$sql_admin .= "1,"; # gender
987
$sql_admin .= "\"31-129\","; # location
988
$sql_admin .= "1,"; # orientation
989
$sql_admin .= "2,"; # drugs
990
$sql_admin .= "1,"; # wheels
991
$sql_admin .= "1,"; # can_host
992
$sql_admin .= "2,"; # drinker
993
$sql_admin .= "1,"; # smoker
994
$sql_admin .= "1,"; # seeking
995
$sql_admin .= "2,"; # seeking_gender
996
$sql_admin .= "6,"; # erection
997
$sql_admin .= "1,"; # bust
998
$sql_admin .= "2,"; # eye_clr
999
$sql_admin .= "3,"; # hair_clr
1000
$sql_admin .= "8,"; # weight
1001
$sql_admin .= "8,"; # height
1002
$sql_admin .= "3,"; # body
1003
$sql_admin .= "\"1901-01-01\","; # enrolled date
1004
$sql_admin .= "2,"; # subscriber
1005
$sql_admin .= "\"1901-01-01\","; # subscription start date
1006
$sql_admin .= "3,"; # subscription type
1007
$sql_admin .= "1,"; # CCID
1008
$sql_admin .= "2,"; # TID
1009
$sql_admin .= "2,"; # security
1010
$sql_admin .= "\"Default Site Moderator Account\")"; # description
1011
1012
my $sql = sql_execute($sql_admin, "Bc_sql.pl - whilst creating 'perchie' account");
1013
if ($sql) {
1014
$rv = 1; # 1 when successfull
1015
} else {
1016
$rv = 0; # something went wrong with the query, check your shit and try again
1017
}
1018
1019
return $rv; # 0 on failure, otherwise 1
1020
#usage: sql_create_perchie();
1021
}
1022
1023
########################
1024
sub sql_create_random_user($) {
1025
#*
1026
# Adds a random user account to the db
1027
# password will always be $DEFAULT_PW_FOR_USER
1028
# security level is set to 1
1029
# location will be 1-1, a city somewhere in Afghanistan (sounds ominous)
1030
#*
1031
my ($num) = @_; # a number of users to create
1032
if ($num < 1) { $num = 1; }
1033
1034
my @sql;
1035
my $rv = 0;
1036
my @countries = get_countries(); # this list should never have a country with no cities
1037
my @races = get_config("races");
1038
my @yesno = get_config("yesno");
1039
my @orientations = get_config("orientations");
1040
my @styles = get_config("styles");
1041
my @genders = get_config("genders");
1042
my @erections = get_config("erections");
1043
my @busts = get_config("busts");
1044
my @eyes = get_config("eyes");
1045
my @hair = get_config("hair");
1046
my @heights = get_config("heights");
1047
my @weights = get_config("weights");
1048
my @bodies = get_config("bodies");
1049
my @themes = get_themes(1);
1050
1051
for (my $i = 0; $i < $num; $i++) {
1052
my $country = int(rand(@countries))+1;
1053
# if selected country doesn't exist, or has no cities, select a new country!
1054
my @cCities = get_country_cities($country);
1055
while (not @cCities) {
1056
# this shouldn't happen
1057
$country = int(rand(@countries))+1;
1058
@cCities = get_country_cities($country);
1059
}
1060
1061
my $newuid = new_uid();
1062
my $mon = int(rand(12))+1;
1063
1064
my $sql_admin = "insert into users values (";
1065
$sql_admin .= "'$newuid',"; # ID
1066
$sql_admin .= "'testuser-$newuid',"; # nickname
1067
$sql_admin .= "'testuser-$newuid\@email.addy',"; #email
1068
$sql_admin .= "'" . (Date::get_today("y", 0) - int(rand(100))) . "-" . Bc_misc::add_zeros($mon) . "-" . Bc_misc::add_zeros(int(rand(Date::get_month_days($mon)))) . "',"; # dob
1069
$sql_admin .= int(rand(2))+1 . ","; # show bday
1070
$sql_admin .= "'1.2.3.4',"; # last ip
1071
$sql_admin .= "'$DEFAULT_PW_FOR_USER',"; # password
1072
$sql_admin .= int(rand(@races))+1 . ","; # race
1073
$sql_admin .= int(rand(@yesno))+1 . ","; # gender
1074
#$sql_admin .= "'1-1',"; # location
1075
$sql_admin .= $DB->quote($country . "-" . (int(rand(@cCities))+1)) . ","; # location
1076
$sql_admin .= int(rand(@orientations))+1 . ","; # orientation
1077
$sql_admin .= int(rand(@yesno))+1 . ","; # drugs
1078
$sql_admin .= int(rand(@yesno))+1 . ","; # wheels
1079
$sql_admin .= int(rand(@yesno))+1 . ","; # can_host
1080
$sql_admin .= int(rand(@yesno))+1 . ","; # drinker
1081
$sql_admin .= int(rand(@yesno))+1 . ","; # smoker
1082
$sql_admin .= int(rand(@styles))+1 . ","; # seeking
1083
$sql_admin .= int(rand(@genders))+1 . ","; # seeking_gender
1084
$sql_admin .= int(rand(@erections))+1 . ","; # erection
1085
$sql_admin .= int(rand(@busts))+1 . ","; # bust
1086
$sql_admin .= int(rand(@eyes))+1 . ","; # eye_clr
1087
$sql_admin .= int(rand(@hair))+1 . ","; # hair_clr
1088
$sql_admin .= int(rand(@weights))+1 . ","; # weight
1089
$sql_admin .= int(rand(@heights))+1 . ","; # height
1090
$sql_admin .= int(rand(@bodies))+1 . ","; # body
1091
$sql_admin .= "'" . Date::get_today("db", 0) . "',"; # enrolled date
1092
$sql_admin .= "1,"; # subscriber
1093
$sql_admin .= "'" . Date::get_today("db", 0) . "',"; # subscription start date
1094
$sql_admin .= "1,"; # subscription type (non-subscriber)
1095
$sql_admin .= "'1',"; # CCID
1096
1097
# my @themes = get_themes(1);
1098
# $test = $themes[(int(rand(@themes)))]; #"203537B0FF";
1099
# $test =~ s/\=(.)*$//;
1100
# $test2 = get_theme_data($test);
1101
# @atest = (); push @atest, $test2;
1102
# $rv .= Html::display_debug_many("get_theme_data(\"$test\")", \@atest, "<br>", 0);
1103
1104
my $tid = $themes[(int(rand(@themes)))]; #"203537B0FF";
1105
$tid =~ s/\=(.)*$//;
1106
$sql_admin .= $DB->quote($tid) . ","; # TID
1107
$sql_admin .= "1,"; # security
1108
$sql_admin .= "'Randomly Generated TEST User Account', "; # description
1109
$sql_admin .= "1)"; # banned flag
1110
1111
push @sql, $sql_admin;
1112
}
1113
1114
if (sql_execute_multi(\@sql, "bc_sql->sql_execute_multi($;$)")) { $rv = @sql; }
1115
1116
return $rv; # the number of accounts added upon success or 0 on failure
1117
#usage: sql_create_random_user(123); # creates 123 accounts with totally randomly selected stats
1118
}
1119
1120
########################
1121
sub sql_create_random_user_updated($) {
1122
#*
1123
# Adds a/many random user account(s)
1124
# password will always be "@pp13P!e$";
1125
# security level is set to 1
1126
# location will be 1-1, a city somewhere in Afghanistan (sounds ominous)
1127
#*
1128
my ($num) = @_; # a number of users to create
1129
if ($num < 1) { $num = 1; }
1130
1131
my $rv = 0;
1132
my @cities = get_cities(1);
1133
my @races = get_config("races");
1134
my @yesno = get_config("yesno");
1135
my @orientations = get_config("orientations");
1136
my @styles = get_config("styles");
1137
my @genders = get_config("genders");
1138
my @erections = get_config("erections");
1139
my @busts = get_config("busts");
1140
my @eyes = get_config("eyes");
1141
my @hair = get_config("hair");
1142
my @heights = get_config("heights");
1143
my @weights = get_config("weights");
1144
my @bodies = get_config("bodies");
1145
my @themes = get_themes(1);
1146
1147
my $sql_admin = "insert into users values ";
1148
for (my $i = 0; $i < $num; $i++) {
1149
my $location = $cities[int(rand(@cities))];
1150
my $newuid = new_uid();
1151
my $mon = int(rand(12))+1;
1152
1153
$sql_admin .= "('$newuid',"; # ID
1154
$sql_admin .= "'testuser-$newuid',"; # nickname
1155
$sql_admin .= "'testuser-$newuid\@email.addy',"; #email
1156
$sql_admin .= "'" . (Date::get_today("y", 0) - int(rand(100))) . "-" . Bc_misc::add_zeros($mon) . "-" . Bc_misc::add_zeros(int(rand(Date::get_month_days($mon)))) . "',"; # dob
1157
$sql_admin .= int(rand(2))+1 . ","; # show bday
1158
$sql_admin .= "'1.2.3.4',"; # last ip
1159
$sql_admin .= "'$DEFAULT_PW_FOR_USER',"; # password
1160
$sql_admin .= int(rand(@races))+1 . ","; # race
1161
$sql_admin .= int(rand(@yesno))+1 . ","; # gender
1162
$sql_admin .= $DB->quote($location) . ","; # location
1163
$sql_admin .= int(rand(@orientations))+1 . ","; # orientation
1164
$sql_admin .= int(rand(@yesno))+1 . ","; # drugs
1165
$sql_admin .= int(rand(@yesno))+1 . ","; # wheels
1166
$sql_admin .= int(rand(@yesno))+1 . ","; # can_host
1167
$sql_admin .= int(rand(@yesno))+1 . ","; # drinker
1168
$sql_admin .= int(rand(@yesno))+1 . ","; # smoker
1169
$sql_admin .= int(rand(@styles))+1 . ","; # seeking
1170
$sql_admin .= int(rand(@genders))+1 . ","; # seeking_gender
1171
$sql_admin .= int(rand(@erections))+1 . ","; # erection
1172
$sql_admin .= int(rand(@busts))+1 . ","; # bust
1173
$sql_admin .= int(rand(@eyes))+1 . ","; # eye_clr
1174
$sql_admin .= int(rand(@hair))+1 . ","; # hair_clr
1175
$sql_admin .= int(rand(@weights))+1 . ","; # weight
1176
$sql_admin .= int(rand(@heights))+1 . ","; # height
1177
$sql_admin .= int(rand(@bodies))+1 . ","; # body
1178
$sql_admin .= "'" . Date::get_today("db", 0) . "',"; # enrolled date
1179
$sql_admin .= "1,"; # subscriber
1180
$sql_admin .= "'" . Date::get_today("db", 0) . "',"; # subscription start date
1181
$sql_admin .= "1,"; # subscription type (non-subscriber)
1182
$sql_admin .= "'1',"; # CCID
1183
1184
# my @themes = get_themes(1);
1185
# $test = $themes[(int(rand(@themes)))]; #"203537B0FF";
1186
# $test =~ s/\=(.)*$//;
1187
# $test2 = get_theme_data($test);
1188
# @atest = (); push @atest, $test2;
1189
# $rv .= Html::display_debug_many("get_theme_data(\"$test\")", \@atest, "<br>", 0);
1190
1191
my $tid = $themes[(int(rand(@themes)))]; #"203537B0FF";
1192
$tid =~ s/\=(.)*$//;
1193
$sql_admin .= $DB->quote($tid) . ","; # TID
1194
$sql_admin .= "1,"; # security
1195
$sql_admin .= "'Randomly Generated TEST User Account', "; # description
1196
$sql_admin .= "1),"; # banned flag
1197
}
1198
1199
$sql_admin =~ s/,$//;
1200
if (sql_execute($sql_admin, "bc_sql->sql_execute_multi(\$;\$) - called by sql_create_random_user_updated(..)") eq 1) { $rv = $num; }
1201
1202
return $rv; # the number of accounts added upon success or 0 on failure
1203
#usage: sql_create_random_user_updated(123); # creates 123 accounts with totally randomly selected stats
1204
}
1205
1206
########################
1207
sub sql_sanitize_db_nicknames() {
1208
#*
1209
# Removes HTML from nicknames currently
1210
# stored in the databasse
1211
#*
1212
#@_; # (no parameters)
1213
1214
my $rv = 1;
1215
my $sql = "select ID, nickname from users";
1216
my $users = sql_execute($sql, "sql_sanitize_db_nicknames()");
1217
if (ref $users eq "HASH") {
1218
# this should NEVER happen. There should always be one admin and one moderator
1219
# so, i'm not going to code anything here
1220
} else {
1221
my $nohtml = HTML::Restrict->new();
1222
foreach my $dataRef (@$users) {
1223
my $nn_processed = $nohtml->process($dataRef->{nickname});
1224
if ($nn_processed ne $dataRef->{nickname}) {
1225
my $update = "update users set nickname=" . $DB->quote($nn_processed) . " where ID='$dataRef->{ID}'";
1226
$rv = sql_execute($update, "sql_sanitize_db_nicknames()");
1227
}
1228
}
1229
}
1230
1231
return $rv; # 1 if process succesfully completed, else 0
1232
#usage: sql_sanitize_db_nicknames();
1233
}
1234
1235
########################################################################
1236
########################################################################
1237
###
1238
### the following are "_exists" functions
1239
###
1240
########################################################################
1241
########################################################################
1242
1243
1244
########################
1245
sub sid_exists($) {
1246
#*
1247
# determines if a session id exists, or not
1248
# returns a hash reference to the data
1249
# or 0 if $sid doesn't exist.
1250
#*
1251
my ($sid) = @_; # a session ID
1252
my $rv = 0;
1253
1254
my $sql = "select * from loggedin where cookie_data=" . $DB->quote($sid);
1255
my $ref = sql_execute($sql, "Bc_sql.pm::sid exists");
1256
if (ref $ref eq "HASH") { $rv = $ref; }
1257
1258
return $rv; # returns either 0 or a reference to a hash
1259
#usage: if (sid_exists($sid)) { print "$sid exists"; }
1260
}
1261
1262
########################
1263
sub theme_exists($) {
1264
#*
1265
# determines if a theme exists, or not
1266
# returns a hash reference of theme data
1267
# or 0 if $tid doesn't exist.
1268
#*
1269
my ($tid) = @_; # a theme ID
1270
my $rv = 0;
1271
1272
if ($tid) {
1273
my $sql = "select * from themes where ID=" . $DB->quote($tid);
1274
my $ref = sql_execute($sql, "Bc_sql.pm::theme exists");
1275
if (ref $ref eq "HASH") { $rv = $ref; }
1276
}
1277
1278
return $rv; # 0 or a reference to a hash of theme data
1279
#usage: if (theme_exists($tid)) { print "$tid exists"; }
1280
}
1281
1282
########################
1283
sub user_exists($) {
1284
#*
1285
# determines if a user exists or not
1286
#*
1287
my ($uid) = @_; # a user ID
1288
my $rv = 0;
1289
1290
if ($uid) {
1291
my $sql = "select ID from users where ID=" . $DB->quote($uid);
1292
my $uref = sql_execute($sql, "Bc_sql.pm::user exists($uid)");
1293
1294
if (ref $uref eq "HASH") {
1295
$rv = 1; # 1 when user exists
1296
}
1297
}
1298
1299
return $rv; # 1 (exists) or 0 (doesn't exist)
1300
#usage: if (user_exists($uid)) { print "$uid exists"; }
1301
}
1302
1303
1304
########################################################################
1305
########################################################################
1306
###
1307
### the following are "get_" functions
1308
###
1309
########################################################################
1310
########################################################################
1311
1312
1313
########################
1314
sub get_zodiac_icon_fn($) {
1315
#*
1316
# gets a zodiac's img file name only!
1317
#*
1318
my ($zid) = @_; # zodiac ID
1319
1320
my $z = "site/404.png";
1321
if ($zid eq 0) { $z = "aquarius.png"; }
1322
if ($zid eq 1) { $z = "gemini.png"; }
1323
if ($zid eq 2) { $z = "capricorn.png"; }
1324
if ($zid eq 3) { $z = "taurus.png"; }
1325
if ($zid eq 4) { $z = "sagittarius.png"; }
1326
if ($zid eq 5) { $z = "scorpio.png"; }
1327
if ($zid eq 6) { $z = "leo.png"; }
1328
if ($zid eq 7) { $z = "cancer.png"; }
1329
if ($zid eq 8) { $z = "libra.png"; }
1330
if ($zid eq 9) { $z = "pisces.png"; }
1331
if ($zid eq 10) { $z = "virgo.png"; }
1332
if ($zid eq 11) { $z = "aries.png"; }
1333
if ($z ne "site/404.png") { $z = "zodiacs/$z"; }
1334
1335
my $zodiac = "<img src=\"/img.pl?i=$z&s=i\">";
1336
1337
return $zodiac; # a zodiac icon
1338
#usage: my $zodiac = get_zodiac_icon_fn($zid);
1339
}
1340
1341
########################
1342
sub get_theme_data($) {
1343
#*
1344
# this calls and returns whatever theme_exists($tid) returns
1345
#*
1346
my ($tid) = @_; # a theme ID
1347
1348
return theme_exists($tid); # see <a href='#theme_exists'>theme_exists</a>
1349
#usage: my $themeDataRef = get_theme_data($someTID);
1350
}
1351
1352
########################
1353
sub get_location($) {
1354
#*
1355
# retrieves the name of the location specified
1356
# ie:
1357
# give "31-1"
1358
# get "Abbotsford, Canada"
1359
#*
1360
my ($loc) = @_; # a location (eg: 31-1)
1361
1362
my $sql = "select * from cities where coords = " . $DB->quote($loc);
1363
my $results = sql_execute($sql, "Bc_sql.pm::get location");
1364
if (ref $results eq "HASH") {
1365
my %city = %$results;
1366
my $name = $city{name} . ", ";
1367
my $country = $city{coords};
1368
$country =~ s/-(.)*//;
1369
1370
# now we need to add the country name
1371
my $csql = "select * from countries where ID = " . $DB->quote($country);
1372
my $cresults = sql_execute($csql, "Bc_sql.pm::get location, getting countries");
1373
if ($cresults) {
1374
my %c = %$cresults;
1375
$name .= $c{name};
1376
} else {
1377
$name .= "invalid country ($country)";
1378
}
1379
1380
return $name; # the name of the city and country
1381
} else {
1382
return "invalid location ($loc)"; # invalid location
1383
}
1384
#usage: my $locName = get_location("31-1");
1385
}
1386
1387
########################
1388
sub get_orientation_asWord($) {
1389
#*
1390
# retrieves an orientation's "name"
1391
#*
1392
my ($o) = @_; # an orientation ID
1393
my $rv = 0;
1394
1395
my $query = "select value from orientations where ID = " . $DB->quote($o);
1396
my $result = sql_execute($query, "Bc_sql.pm::get orientation as word"); # a hash reference
1397
if (ref $result eq "HASH") { $rv = $result->{value}; }
1398
1399
return $rv; # the orienation as a word (like "Heterosexual")
1400
#usage: my $o = get_orientation_asWord(1);
1401
}
1402
1403
########################
1404
sub get_race_asWord($) {
1405
#*
1406
# retrieves an ethnicity's "name"
1407
#*
1408
my ($e) = @_; # an ethnicity ID
1409
1410
my $query = "select value from races where ID = " . $DB->quote($e);
1411
my $result = sql_execute($query, "Bc_sql.pm::get race as word"); # a hash reference
1412
my $rv = 0;
1413
if (ref $result eq "HASH") {
1414
$rv = $result->{value};
1415
}
1416
1417
return $rv; # the ethnicity as a word, if found, or 0
1418
#usage: my $r = get_race_asWord(1);
1419
}
1420
1421
########################
1422
sub get_reason_asWord($) {
1423
#*
1424
# retrieves a reason code's related text
1425
#*
1426
my ($r) = @_; # an reason ID
1427
1428
my $query = "select value from reasons where ID = " . $DB->quote($r);
1429
my $result = sql_execute($query, "Bc_sql.pm::get reason as word"); # a hash reference
1430
my $rv = 0;
1431
if (ref $result eq "HASH") {
1432
$rv = $result->{value};
1433
}
1434
1435
return $rv; # the reason code as a word, if found, or 0
1436
#usage: my $r = get_reason_asWord(1);
1437
}
1438
1439
########################
1440
sub get_reasons() {
1441
#*
1442
# retrieves all reason codes and related text
1443
#*
1444
#@_; # (no parameters)
1445
1446
my $query = "select * from reasons";
1447
my $result = sql_execute($query, "Bc_sql.pm::get reasons"); # a hash reference
1448
my $rv = 0;
1449
my @data = ();
1450
if (ref $result eq "ARRAY") {
1451
foreach my $hashRef (@$result) {
1452
push @data, $hashRef->{ID} . "=" . $hashRef->{value};
1453
}
1454
}
1455
1456
# so now $rv is a reference to an array of hash references
1457
# need to build the array so a drop down can read the data
1458
return @data; # the reason codes
1459
#usage: my $r = get_reasons();
1460
}
1461
1462
########################
1463
sub get_security_asWord($) {
1464
#*
1465
# retrieves a value from the security table
1466
#*
1467
my ($sec) = @_; # a security ID (eg: 1)
1468
$sec = lc $sec;
1469
my $query = "select value from security where ID = " . $DB->quote($sec);
1470
my $result = sql_execute($query, "Bc_sql.pm::get security as word");
1471
1472
return %$result{value}; # a security level value (eg: mod);
1473
#usage: my $security = get_security_asWord(2);
1474
}
1475
1476
########################
1477
sub get_security_fromWord($) {
1478
#*
1479
# retrieves a value from the security table
1480
#*
1481
my ($sec) = @_; # a security name (eg: superadministrator)
1482
$sec = lc $sec;
1483
my $query = "select ID from security where value=" . $DB->quote($sec);
1484
my $result = sql_execute($query, "Bc_sql.pm::get security from word");
1485
1486
return %$result{value}; # a security level value (eg: 1);
1487
#usage: my $security = get_security_fromWord("superadministrator");
1488
}
1489
1490
########################
1491
sub get_security_asWord_friendly($) {
1492
#*
1493
# retrieves the FRIENDLY_NAME value from the security table
1494
#*
1495
my ($sec) = @_; # a security ID (eg: 1)
1496
my $query = "select friendly_name as value from security where ID=" . $DB->quote($sec);
1497
my $result = sql_execute($query, "Bc_sql.pm::get security as word friendly");
1498
my $rv;
1499
1500
if (ref $result eq "HASH") { $rv = %$result{value}; } else { $rv = $result; }
1501
1502
return $rv; # a security level value (eg: mod);
1503
#usage: my $seeking = get_security_asWord_friendly($USER_DATA->{security});
1504
}
1505
1506
########################
1507
sub get_seeking_asWord($) {
1508
#*
1509
# retrieves a value from the seeking table
1510
#*
1511
my ($sid) = @_; # a seeking ID (eg: 1)
1512
1513
my $query = "select value from styles where ID = " . $DB->quote($sid);
1514
my $result = sql_execute($query, "Bc_sql.pm::get seeking as word");
1515
my $rv = 0;
1516
if (ref $result eq "HASH") {
1517
$rv = $result->{value};
1518
} else {
1519
if ($sid eq 999) { $rv = "Anything"; }
1520
}
1521
1522
return $rv; # a scalar, or 0 on failure
1523
#usage: my $seeking = get_seeking_asWord(2);
1524
}
1525
1526
########################
1527
sub get_site_name() {
1528
#*
1529
# retrieves the name of the website
1530
#*
1531
#@_; # (no parameters)
1532
1533
my $name = get_constant("SITE_NAME");
1534
return $name; # a scalar
1535
#usage: my $site_name = get_site_name();
1536
}
1537
1538
########################
1539
sub get_config_asWord($$;$) {
1540
#*
1541
# retrieves the name of a given ID of a given "config" table
1542
# give "value" or "friendly_name" (or, i guess, whatever) to
1543
# $column
1544
#*
1545
my ($cfg, $id, $column) = @_; # a "configuration" table (eg: eyes, hair, etc) && ID of value to retrieve && value or friendly name? (optional, defaults to 'value')
1546
if (not $column) { $column = "value"; }
1547
my $rv = 0;
1548
1549
if (lc($cfg) eq "seeking") { $cfg = "styles"; }
1550
1551
my $sql = "select " . $DB->quote_identifier($column) . " from " . $DB->quote($cfg) . " where ID = " . $DB->quote($id);
1552
my $ref = sql_execute($sql, "Bc_sql.pm::get config as word: $cfg, $id, $column");
1553
if (ref $ref eq "HASH") { $rv = $ref->{$column}; }
1554
1555
if ($id eq 888) { $rv = "Ask Me"; }
1556
1557
return $rv; # 0 or a word
1558
#usage: my $v = get_config_asWord("security", $user->{security}, "friendly_name");
1559
}
1560
1561
########################
1562
sub sql_get_user_stat($$;$) {
1563
#*
1564
# retrieves a stat for the specified uid
1565
#*
1566
my ($uid, $stat, $DEBUG_SQL_GET_USER_STAT) = @_; # uid && name of stat to retreive && debug mode
1567
1568
my $doby = 0;
1569
my $dobd = 0;
1570
my $dobm = 0;
1571
my $rv = 0;
1572
my $sql;
1573
1574
if (user_exists($uid)) {
1575
$sql = "select " . $DB->quote_identifier($stat) . " as value from users where ID=" . $DB->quote($uid);
1576
1577
if ($stat eq "country" or
1578
$stat eq "city" or
1579
$stat eq "location") {
1580
$sql = "select location from users where ID = " . $DB->quote($uid);
1581
my $ref = sql_execute($sql, "Bc_sql.pm::sql get user stat, 1");
1582
if ($ref > 0) {
1583
my %hash = %$ref;
1584
my ($country, $city) = split("-", $hash{location});
1585
1586
if ($stat eq "country") {
1587
$rv = $country; # a country ID
1588
} elsif ($stat eq "city") {
1589
$rv = $city; # a city ID
1590
} else {
1591
my $location = $country . "-" . $city;
1592
$rv = $location; # a location
1593
}
1594
}
1595
} elsif ($stat eq "doby" or
1596
$stat eq "dobm" or
1597
$stat eq "dobd") {
1598
$sql = "select dob from users where ID = " . $DB->quote($uid);
1599
my $ref = sql_execute($sql, "Bc_sql.pm::sql get user stat, 2");
1600
if ($ref > 0) {
1601
my %hash = %$ref;
1602
($doby, $dobm, $dobd) = split("-", $hash{dob});
1603
if ($stat eq "doby") {
1604
$rv = $doby; # a birth year
1605
} elsif ($stat eq "dobm") {
1606
$rv = $dobm; # a birth month
1607
} else {
1608
$rv = $dobd; # a birth day
1609
}
1610
}
1611
} else {
1612
my $ref = sql_execute($sql, "Bc_sql.pm::sql get user stat, 3");
1613
if ($ref) {
1614
$rv = %$ref{value};
1615
} else {
1616
$rv = $ref;
1617
}
1618
}
1619
}
1620
1621
if ($DEBUG_SQL_GET_USER_STAT) { $rv .= " - column=$stat - sql=$sql"; }
1622
1623
return $rv; # a scalar (could be the return value of sql_execute if something went wrong there)
1624
#usage: my $nickname = sql_get_user_stat($uid, "nickname");
1625
}
1626
1627
########################
1628
sub get_phrase() {
1629
#*
1630
# retrieves a random phrase
1631
#*
1632
#@_; # (no parameters)
1633
my $rv = 0;
1634
1635
my $sql = sql_execute("select * from phrases", "Bc_sql.pm::get phrase");
1636
if (ref $sql eq "HASH") {
1637
my @phrases = split(/\n/, $sql->{value});
1638
$rv = $phrases[rand(@phrases)];
1639
} else {
1640
$rv = "phrase selection failed";
1641
}
1642
1643
return $rv; # 0 on failure, or a random phrase!
1644
#usage: my $phrase = get_phrase();
1645
}
1646
1647
########################
1648
sub get_eye_clr_asWord($) {
1649
#*
1650
# retrieves an eye clr
1651
# returns 0 on failure
1652
#*
1653
my ($clr) = @_; # an eye clr (eg: 1)
1654
my $query = "select value from eyes where ID = " . $DB->quote($clr);
1655
my $result = sql_execute($query, "Bc_sql.pm::get eye clr as word");
1656
my $rv = 0;
1657
1658
if ($result and ref $result eq "HASH") { $rv = $result->{value}; }
1659
1660
return $rv; # an eye clr (eg: blue)
1661
#usage: my $eye_clr = get_eye_clr_asWord(1);
1662
}
1663
1664
########################
1665
sub get_gender_asWord($) {
1666
#*
1667
# retrieves a gender
1668
#*
1669
my ($gender) = @_; # a gender ID (eg: 1)
1670
my $query = "select value from genders where ID = " . $DB->quote($gender);
1671
my $result = sql_execute($query, "Bc_sql.pm::get gender as word");
1672
my $rv = 0;
1673
1674
if ($result and ref $result eq "HASH") { $rv = $result->{value}; }
1675
1676
return $rv; # an gender (eg: Gal)
1677
#usage: my $gender = get_gender_asWord(2);
1678
}
1679
1680
########################
1681
sub get_hair_clr_asWord($) {
1682
#*
1683
# retrieves a hair clr
1684
#*
1685
my ($clr) = @_; # a hair clr ID (eg: 1)
1686
my $rv = 0;
1687
my $query = "select value from hair where ID = " . $DB->quote($clr);
1688
my $ref = sql_execute($query, "Bc_sql.pm::get hair clr as word");
1689
if (ref $ref eq "HASH") {
1690
if ($ref->{value}) { $rv = $ref->{value}; }
1691
}
1692
1693
return $rv; # a scalar
1694
#usage: my $hair_clr = get_hair_clr_asWord(1);
1695
}
1696
1697
########################
1698
sub get_height_asWord($) {
1699
#*
1700
# retrieves a weight
1701
#*
1702
my ($h) = @_; # a height ID (eg: 1)
1703
1704
my $query = "select value from heights where ID = ". $DB->quote($h);
1705
my $result = sql_execute($query, "Bc_sql.pm::get height as word");
1706
my $rv = 0;
1707
1708
if ($result and ref $result eq "HASH") {
1709
my $v = $result->{value};
1710
if ($v =~ /\<|\>/) { $rv = "$v"; } else { $rv = "~$v"; }
1711
}
1712
1713
return $rv; # a height (eg: ~6');
1714
#usage: my $weight = get_weight_asWord(1);
1715
}
1716
1717
########################
1718
sub get_home_page(;$$$$) {
1719
#*
1720
# retrieves the appropriate home page HTML
1721
# this will not replace <b>all</b> square bracketed
1722
# words with the correct content - that
1723
# <b>must</b> be done elsewhere, due to the website's
1724
# architecture.
1725
#
1726
# replaces [PHRASE] and [NICKNAME] but not
1727
# others (namely [top10members], [top10matches],
1728
# [MAIL], etc)
1729
#
1730
# kind can be: GUEST or LOGGEDIN
1731
# anything else causes the DB to return nothing!
1732
#*
1733
my ($spacing, $fromDB, $asKind, $DEBUG) = @_; # spacing for pretty printing html output (optional) && retrieve text from DB unaltered (optional, default = 0) && force a certain "kind" of homepage to retrieve (optional, default = auto selected) && debug mode (optional, default = 0)
1734
1735
my $hpText = "";
1736
my $kind = "GUEST";
1737
my $nnText = "Visitor";
1738
1739
if ($LOGGEDIN) {
1740
$kind = "LOGGEDIN";
1741
$nnText = sql_get_user_stat($LOGGEDIN, "nickname");
1742
}
1743
1744
if ($asKind) { $kind = $asKind; }
1745
1746
my $table_name = "homepage";
1747
if ($DEBUG) {
1748
$table_name .= "_temp";
1749
$hpText = "DEBUG MODE ENABLED<br>table name: $table_name<hr>\n";
1750
}
1751
1752
my $sql = "select value from $table_name where name = " . $DB->quote($kind);
1753
my $ref = sql_execute($sql, "Bc_sql.pm::get home page");
1754
# well, just in case there's a glitch (cuz...i'm lucky that way!)
1755
if (ref $ref eq "HASH") {
1756
my %hash = %$ref;
1757
$hpText .= $hash{value};
1758
} else {
1759
# either we got no data
1760
# or, we got an array of a bunch of HTML pages!
1761
# either way, it isn't what's needed here
1762
$hpText = 0;
1763
}
1764
1765
if (not $fromDB) {
1766
# now, replace the lines within square brackets in them with the appropriate content
1767
$hpText =~ s/\[NICKNAME\]/$nnText/;
1768
my $rPhrase = get_phrase();
1769
$hpText =~ s/\[PHRASE\]/$rPhrase/;
1770
$hpText =~ s/^$spacing//;
1771
}
1772
1773
return $hpText; # a scalar
1774
#usage: my $hphtml = get_home_page();
1775
}
1776
1777
########################
1778
sub get_about_page() {
1779
#*
1780
# retrieves the about page text
1781
#*
1782
#@_; # (no parameters)
1783
my $sql = "select value from misc where name = 'about'";
1784
my $rv = sql_execute($sql, "Bc_sql.pm::get about page")->{value};
1785
1786
return $rv; # a scalar of HTML
1787
#usage: my $about = get_about_page();
1788
}
1789
1790
########################
1791
sub get_terms_page() {
1792
#*
1793
# retrieves the terms page text
1794
#*
1795
#@_; # (no parameters)
1796
my $sql = "select value from misc where name = 'terms'";
1797
my $rv = sql_execute($sql, "Bc_sql.pm::get terms page")->{value};
1798
1799
return $rv; # a scalar of HTML
1800
#usage: my $terms = get_terms_page();
1801
}
1802
1803
########################
1804
sub get_privacy_page() {
1805
#*
1806
# retrieves the privacy page text
1807
#*
1808
#@_; # (no parameters)
1809
my $sql = "select value from misc where name = 'privacy'";
1810
my $rv = sql_execute($sql, "Bc_sql.pm::get privacy page")->{value};
1811
1812
return $rv; # a scalar of HTML
1813
#usage: my $privacy = get_privacy_page();
1814
}
1815
1816
########################
1817
sub get_legals_page() {
1818
#*
1819
# retrieves the legals page text
1820
#*
1821
#@_; # (no parameters)
1822
my $sql = "select value from misc where name = 'legals'";
1823
my $rv = sql_execute($sql, "Bc_sql.pm::get legals page")->{value};
1824
1825
return $rv; # a scalar of HTML
1826
#usage: my $legals = get_legals_page();
1827
}
1828
1829
########################
1830
sub get_refunds_page() {
1831
#*
1832
# retrieves the refunds page text
1833
#*
1834
#@_; # (no parameters)
1835
my $sql = "select value from misc where name = 'refunds'";
1836
my $rv = sql_execute($sql, "Bc_sql.pm::get refunds page")->{value};
1837
1838
return $rv; # a scalar of HTML
1839
#usage: my $refunds = get_refunds_page();
1840
}
1841
1842
########################
1843
sub get_data_policy_page() {
1844
#*
1845
# retrieves the data policy page text
1846
#*
1847
#@_; # (no parameters)
1848
my $sql = "select value from misc where name = 'data_policy'";
1849
my $rv = sql_execute($sql, "Bc_sql.pm::get data policy page")->{value};
1850
1851
return $rv; # a scalar of HTML
1852
#usage: my $data_policy = get_data_policy_page();
1853
}
1854
1855
########################
1856
sub get_bans() {
1857
#*
1858
# retrieves a list of banned UID's
1859
#*
1860
#@_; # (no parameters)
1861
my @rv = ();
1862
1863
my $sql = "select ID from users where banned='2'";
1864
my $result = sql_execute($sql, "sql -> get bans");
1865
if (ref $result eq "HASH") {
1866
push @rv, $result->{ID};
1867
} else {
1868
foreach my $ref (@$result) {
1869
push @rv, $ref->{ID};
1870
}
1871
}
1872
1873
return @rv; # an array
1874
#usage: my @bans = get_bans();
1875
}
1876
1877
########################
1878
sub get_beta_users(;$) {
1879
#*
1880
# retrieves a list of beta user's UID's
1881
# excludes invalid UID's
1882
# or counts the number of beta users
1883
#*
1884
my ($asCountOnly) = @_; # number of UIDs instead of a list (optional)
1885
my $rv;
1886
1887
if ($asCountOnly) {
1888
my $sql = "select UID from beta_users where expired='1' and opted_out='1'";
1889
my $result = sql_execute($sql, "sql -> get beta users (as count)");
1890
if (ref $result eq "HASH") {
1891
# hash reference
1892
if (user_exists($result->{UID}))
1893
{ $rv = 1; } else
1894
{ $rv = 0; }
1895
} else {
1896
my $count = 0;
1897
foreach my $uid (@$result) {
1898
if (user_exists($uid->{UID})) { $count++; }
1899
}
1900
$rv = $count;
1901
}
1902
} else {
1903
my $sql = "select UID from beta_users where expired='1' and opted_out='1'";
1904
my $result = sql_execute($sql, "sql -> get beta users (as list)");
1905
my @arr = ();
1906
if (ref $result eq "HASH") {
1907
if (user_exists($result->{UID})) {
1908
push @arr, $result->{UID};
1909
}
1910
} else {
1911
foreach my $ref (@$result) {
1912
if (user_exists($ref->{UID})) {
1913
push @arr, $ref->{UID};
1914
}
1915
}
1916
}
1917
1918
$rv = \@arr;
1919
}
1920
1921
return $rv; # an array reference, or a count
1922
#usage: my $bcount = get_beta_users(1);
1923
}
1924
1925
########################
1926
sub get_help_page() {
1927
#*
1928
# retrieves the about page HTML
1929
#*
1930
#@_; # (no parameters)
1931
my $rv = 0;
1932
1933
my $sql = "select value from misc where name = 'help'";
1934
$rv = sql_execute($sql, "Bc_sql.pm::get help page");
1935
if (ref $rv eq "HASH") { $rv = $rv->{value}; } else { $rv = 0; }
1936
1937
return $rv # whatever sql_execute(...) returns
1938
#usage: my $site_name = get_help_page();
1939
}
1940
1941
########################
1942
sub get_config($;$$) {
1943
#*
1944
# to generate an array of "config" data like what's
1945
# found in the zodiacs or bodies tables
1946
#
1947
# each element of the array is only a value
1948
# the list can be empty
1949
#*
1950
my ($cfg, $asRef, $col) = @_; # a "configuration" table (eg: eyes, hair, etc) && rVal as reference (optional, default = 0)
1951
if (not $col) { $col = "*"; }
1952
if ($col ne "*" and
1953
$col ne "ID" and
1954
$col ne "value" and
1955
$col ne "subject") {
1956
$col = "*";
1957
}
1958
my @values = ();
1959
1960
my $sql = "select $col from " . $DB->quote($cfg) . " order by ID";
1961
if ($cfg eq "mod_msgs") { $sql = "select *, subject as value from " . $DB->quote($cfg) . " order by subject"; $col = "ignored"; }
1962
my $ref = sql_execute($sql, "Bc_sql.pm::get_config($cfg)");
1963
if (ref $ref eq "HASH") {
1964
if ($col eq "*") {
1965
if ($ref->{value}) {
1966
push @values, $ref->{value};
1967
}
1968
} else {
1969
if ($ref->{$col}) {
1970
push @values, $ref->{$col};
1971
}
1972
}
1973
} elsif (ref $ref eq "ARRAY") {
1974
foreach my $element (@$ref) {
1975
if ($col eq "*") {
1976
if ($element->{value}) {
1977
push @values, $element->{value};
1978
}
1979
} else {
1980
if ($element->{$col}) {
1981
push @values, $element->{$col};
1982
}
1983
}
1984
}
1985
}
1986
1987
if ($asRef) {
1988
return \@values; # or a reference to a list of values
1989
} else {
1990
return @values; # a list of values
1991
}
1992
1993
#usage: my @eyes = get_config("eyes");
1994
}
1995
1996
########################
1997
sub get_error_message($) {
1998
#*
1999
# retrieves the message associated with a specified error
2000
#*
2001
my ($code) = @_; # code of error to retreive
2002
my $rv = 0;
2003
2004
if ($DB) {
2005
if (@ERRORS) {
2006
foreach my $element (@ERRORS) {
2007
if ($element->{code} eq $code) {
2008
$rv = $element->{desc};
2009
last;
2010
}
2011
}
2012
} else {
2013
my $sql = "select desc from errors where code = " . $DB->quote($code);
2014
$rv = sql_execute($sql, "Bc_sql.pm::get error");
2015
# 0, or a hash reference, or a non-referencing scalar (a string)
2016
$rv = $sql;
2017
}
2018
}
2019
2020
return $rv; # a scalar
2021
#usage: my $e = get_error_message(-1104);
2022
}
2023
2024
########################
2025
sub get_weight_asWord($) {
2026
#*
2027
# retrieves a weight
2028
#*
2029
my ($w) = @_; # a weight ID (eg: 1)
2030
2031
my $query = "select value from weights where ID = ". $DB->quote($w);
2032
my $result = sql_execute($query, "Bc_sql.pm::get weight as word");
2033
my $rv = 0;
2034
2035
if ($result and ref $result eq "HASH") { $rv = "~" . $result->{value} . " lbs"; }
2036
2037
return $rv; # a weight (eg: ~100 lbs);
2038
#usage: my $weight = get_weight_asWord(1);
2039
}
2040
2041
########################
2042
sub get_zodiacs() {
2043
#*
2044
# generates an array of zodiac names
2045
#*
2046
#@_; # (no parameters)
2047
2048
my @zodiacs = get_config("zodiacs");
2049
return @zodiacs; # a list of zodiacs
2050
#usage: my @zodiacs = get_zodiacs();
2051
}
2052
2053
########################
2054
sub get_body_asWord($) {
2055
#*
2056
# retrieves a body type
2057
#*
2058
my ($ID) = @_; # a body type ID (eg: 1)
2059
my $rv = "";
2060
2061
my $query = "select value from bodies where ID=". $DB->quote($ID);
2062
my $result = sql_execute($query, "Bc_sql.pm::get body as word");
2063
2064
if (ref $result eq "HASH") {
2065
$rv = %$result{value};
2066
}
2067
2068
return $rv; # a body type (eg: Athletic);
2069
#usage: my $body = get_body_asWord(1);
2070
}
2071
2072
########################
2073
sub get_cities(;$$) {
2074
#*
2075
# generates an array of ALL cities
2076
# each element consists of coords=name pairs
2077
# if $coords_only is set, then each element will
2078
# be just the city's coordinates
2079
# if $asRef eq 1, then an array ref is returned
2080
#*
2081
my ($coords_only, $asRef) = @_; # only coordinates, no names (optional, default = 0) && rVal as reference (optional, default = 0)
2082
my @rv = ();
2083
2084
my $sql = sql_execute("select coords, name from cities order by name", "Bc_sql.pm::get cities");
2085
if ($sql > 0) {
2086
my @results = @$sql;
2087
my @cities;
2088
foreach my $cityRef (@results) {
2089
my %city = %$cityRef;
2090
if ($coords_only) {
2091
push @cities, "$city{coords}";
2092
} else {
2093
push @cities, "$city{coords}=$city{name}";
2094
}
2095
}
2096
2097
@rv = @cities; # a list of cities
2098
}
2099
2100
if (not $asRef) {
2101
return @rv; # an array of all city names
2102
} else {
2103
return \@rv; # a reference to an array of all city names
2104
}
2105
#usage: my @cities = get_cities();
2106
}
2107
2108
########################
2109
sub get_city_name($) {
2110
#*
2111
# retrieves ONLY the name of the specified city
2112
#*
2113
my ($location) = @_; # a location (eg: 31-1)
2114
2115
my $query = "select name from cities where coords = ". $DB->quote($location);
2116
my $result = sql_execute($query, "Bc_sql.pm::get city name"); # a hash reference
2117
my $cname = 0;
2118
2119
if ($result) {
2120
if (ref $result eq "HASH")
2121
{ $cname = $result->{name}; } else
2122
{ $cname = $location; }
2123
}
2124
2125
return $cname; # the name of the city (can be "")
2126
#usage: my $city_name = get_city_name($location);
2127
}
2128
2129
########################
2130
sub get_country_cities($;$$) {
2131
#*
2132
# generates an array of ALL cities in a given country;
2133
# each element consists of coords=name pairs
2134
# coords ought to be, for eg, 31-1
2135
#*
2136
my ($country, $add999, $asRef) = @_; # a country ID && add "all" option (optional, default = 0) && rVal as reference
2137
2138
# is country valid?
2139
my $checksql = "select * from countries where ID=" . $DB->quote($country);
2140
if (sql_execute($checksql, "Bc_sql::get_country_cities()")) {
2141
my @allCities = get_cities(); # results in loc=name (eg: 31-1=Abbotsford)
2142
my @cities;
2143
2144
if ($country ne -1) {
2145
if ($add999) {
2146
push @cities, "999-999=$add999";
2147
}
2148
if ($country ne 999) {
2149
foreach my $cityData (@allCities) {
2150
my @city = split("=", $cityData);
2151
my $countryID = $city[0];
2152
$countryID =~ s/-(.)*$//i;
2153
if ($countryID eq $country) { push @cities, "$cityData"; }
2154
}
2155
}
2156
}
2157
2158
2159
if (not $asRef) {
2160
return @cities; # a list of cities for the requested country ID (can be empty)
2161
} else {
2162
return \@cities; # reference to a list of cities for the requested country ID (can be empty)
2163
}
2164
} else {
2165
return undef; # undef when invalid country ID
2166
}
2167
#usage: my @cities = get_cities();
2168
}
2169
2170
########################
2171
sub get_country_name($) {
2172
#*
2173
# retrieves ONLY the name of the specified country
2174
#*
2175
my ($location) = @_; # a location (eg: 31-1)
2176
2177
my $country = $location;
2178
$country =~ s/-(.)*//;
2179
my $query = "select name from countries where ID=". $DB->quote($country);
2180
my $result = sql_execute($query, "Bc_sql.pm::get country name"); # a hash reference
2181
my $rv = 0;
2182
if (ref $result eq "HASH") {
2183
my %hash = %$result;
2184
$rv = $hash{name};
2185
} else {
2186
$rv = "";
2187
}
2188
2189
return $rv; # the name of the country (can be "")
2190
#usage: my $city_name = get_city_name($location);
2191
}
2192
2193
########################
2194
sub get_countries(;$) {
2195
#*
2196
# generates an array of ALL countries;
2197
# each element will consist of coords=name pairs
2198
# will always return an array
2199
#*
2200
my ($asRef) = @_; # rVal as reference (optional, default = 0)
2201
my @rv = ();
2202
2203
my $sql = sql_execute("select ID, name from countries order by name", "Bc_sql.pm::get countries");
2204
if ($sql > 0) {
2205
my @results = @$sql;
2206
foreach my $countryRef (@results) {
2207
my %country = %$countryRef;
2208
push @rv, "$country{ID}=$country{name}";
2209
}
2210
}
2211
2212
if (not $asRef) {
2213
return @rv; # an array (can be empty)
2214
} else {
2215
return \@rv; # an array reference (can point to an empty array)
2216
}
2217
#usage: my @countries = get_countries();
2218
}
2219
2220
########################
2221
sub get_theme_purchases(;$$) {
2222
#*
2223
# generates an array of ALL purchased themes
2224
# for a given user.
2225
# each element consists of a simple TID
2226
#*
2227
my ($uid, $DEBUG_THEME_PURCHASES) = @_; # a uid (optional, or uses loggedin uid)
2228
if (not $uid) { $uid = $LOGGEDIN; }
2229
my @purchases = ();
2230
2231
my $sql = "select * from theme_purchases where UID = " . $DB->quote($uid);
2232
my $sec = sql_get_user_stat($LOGGEDIN, "security");
2233
my $COL = "TID";
2234
if ($sec eq get_security("administrator") or $sec eq get_security("superadministrator")) {
2235
$sql = "select * from themes where premium = '2'";
2236
$COL = "ID";
2237
}
2238
2239
my $ref = sql_execute($sql, "get_theme_purchases()");
2240
if (ref $ref eq "HASH") {
2241
push @purchases, $ref->{$COL};
2242
} else {
2243
if (@$ref) {
2244
foreach my $themeRef (@$ref) {
2245
push @purchases, $themeRef->{$COL};
2246
}
2247
}
2248
}
2249
2250
if ($DEBUG_THEME_PURCHASES) {
2251
push @purchases, "DEBUG THEME PURCHASES ENABLED";
2252
if (ref $ref eq "HASH") {
2253
push @purchases, "Hash reference (1 element)";
2254
} elsif (ref $ref eq "ARRAY") {
2255
push @purchases, "Array reference, size=" . (@$ref);
2256
} else {
2257
push @purchases, "Other: $ref";
2258
}
2259
push @purchases, "Security level: $sec";
2260
push @purchases, "Admin security level: " . get_security("administrator");
2261
push @purchases, "SQL: " . $sql;
2262
}
2263
2264
return @purchases; # a list of purchased themes (can be empty)
2265
#usage: my @theme_purchases = get_theme_purchases;
2266
}
2267
2268
########################
2269
sub get_themes(;$$) {
2270
#*
2271
# generates an array of ALL themes
2272
# each element consists of tid=name pairs
2273
# this will exclude theme names starting with <i>{EDITOR}</i>
2274
# !this function could be heavily modified, and will be soon enough!
2275
#*
2276
my ($nopremium, $include_editor_themes) = @_; # exclude premium themes (optional)
2277
2278
my $sql = sql_execute("select ID, name, premium from themes where not ID='1111111111' order by name collate nocase", "Bc_sql::get themes");
2279
my @themes = ();
2280
2281
# for debugging
2282
#push @themes, "$nopremium=$nopremium";
2283
#push @themes, "$include_editor_themes=$include_editor_themes";
2284
2285
if ($sql) {
2286
my @results = @$sql;
2287
foreach my $themeRef (@results) {
2288
if ($nopremium) {
2289
if ($themeRef->{premium} ne 2) {
2290
if ($themeRef->{name} =~ /\{EDITOR\}/) {
2291
if ($include_editor_themes) {
2292
push @themes, "$themeRef->{ID}=$themeRef->{name}=$themeRef->{premium}";
2293
}
2294
} else {
2295
push @themes, "$themeRef->{ID}=$themeRef->{name}=$themeRef->{premium}";
2296
}
2297
}
2298
} else {
2299
if ($themeRef->{name} =~ /\{EDITOR\}/) {
2300
if ($include_editor_themes) {
2301
push @themes, "$themeRef->{ID}=$themeRef->{name}=$themeRef->{premium}";
2302
}
2303
} else {
2304
push @themes, "$themeRef->{ID}=$themeRef->{name}=$themeRef->{premium}";
2305
}
2306
}
2307
}
2308
}
2309
2310
return @themes; # a list of theme ID's
2311
#usage: my @themes = get_themes();
2312
}
2313
2314
########################
2315
sub get_top10_fma_counts() {
2316
#*
2317
# will get a list of 10 users who have the most FMA's
2318
#*
2319
#@_; # (no parameters)
2320
my $sql = "select u.ID as ID, u.security as security, f.to_UID as UID from users u, fuck_alerts f where u.ID=f.to_UID and not u.security=4 and not u.security=3 group by f.to_UID order by count(f.to_UID) desc limit 10";
2321
#my $sql = "SELECT security=(SELECT security from users), to_UID as UID FROM fuck_alerts where not security='3' GROUP BY to_UID ORDER BY COUNT(to_UID) DESC LIMIT 10";
2322
my $result = sql_execute($sql, "get top10 fma counts");
2323
my @rv = ();
2324
2325
if (ref $result eq "HASH") {
2326
push @rv, $result->{UID};
2327
} elsif (ref $result eq "ARRAY") {
2328
foreach my $ref (@$result) {
2329
push @rv, $ref->{UID};
2330
}
2331
}
2332
2333
return @rv; # a list (can be empty)
2334
#usage: my @top10fma = get_top10_fma_counts();
2335
}
2336
2337
########################
2338
sub get_security(;$$$) {
2339
#*
2340
# gets the sID associated with a named security level
2341
# valid names can be found in the "security" table of the database
2342
# or via the administration pages
2343
# if no sID_name is given, this function will then return
2344
# a list reference. of which, each element will be a reference to
2345
# each security level's data (ID, name, and friendly name)
2346
#*
2347
my ($sID_name, $DB_table_name, $DB_col_name) = @_; # name of security level ID (eg: moderator, optional, default returns array ref to all security levels) && table name to lookup (default: security) && given table's "value" column
2348
if (not $DB_table_name) { $DB_table_name = "sec_levels"; }
2349
if (not $DB_col_name) { $DB_col_name = "value"; }
2350
2351
my $rv = 0; # assume bad security name
2352
2353
if (not $sID_name) {
2354
# there will always be more than one security level, so we won't bother checking
2355
# if sql_execute returned a hash ref, or an array ref - it will be an array ref!
2356
my $sql = "select * from $DB_table_name";
2357
$rv = sql_execute($sql, "get security", 1);
2358
} else {
2359
# so now let's get the requested sec level ID
2360
my $sql = "select ID from $DB_table_name where lower($DB_col_name) like " . $DB->quote(lc($sID_name));
2361
my $vRef = sql_execute($sql, "get security");
2362
if (ref $vRef eq "HASH") {
2363
if ($vRef->{ID}) { $rv = $vRef->{ID}; }
2364
}
2365
}
2366
2367
return $rv; # the ID associated with the requested security level, or a reference to them all
2368
#usage: my $securityID = get_security("admininstrator");
2369
}
2370
2371
########################
2372
sub get_membership_type(;$) {
2373
#*
2374
# gets the ID associated with a named membership type
2375
# valid names can be found in the "membership_types" table of the database
2376
# or via the administration pages
2377
# if no mID_name is given, this function will then return
2378
# a list reference. of which, each element will be a reference to
2379
# each membership type's data (ID, name)
2380
#*
2381
my ($mID_name) = @_; # name of membership type ID (eg: basic, optional, default returns array ref to all membership types)
2382
2383
my $rv = 1; # assume the lowest membership type
2384
2385
if (not $mID_name) {
2386
# there will always be more than one membership type, so we won't bother checking
2387
# if sql_execute returned a hash ref, or array ref - it will be an array ref!
2388
my $sql = "select * from membership_types";
2389
$rv = sql_execute($sql, "get membership type");
2390
} else {
2391
# so now let's get the requested membership type ID
2392
my $sql = "select ID from membership_types where lower(value) like " . $DB->quote(lc($mID_name));
2393
my $vRef = sql_execute($sql, "get membership type");
2394
if (ref $vRef eq "HASH") {
2395
if ($vRef->{ID}) { $rv = $vRef->{ID}; }
2396
}
2397
}
2398
2399
return $rv; # the ID associated with the requested membership type, or a reference to them all
2400
#usage: my $mTypeID = get_membership_type("basic");
2401
}
2402
2403
########################
2404
sub get_users(;$$$$) {
2405
#*
2406
# gets a list of all user IDs only
2407
# with or without admins included
2408
# excludes banned users, too
2409
# can be ordered by nickname
2410
# can optionally exclude a UID
2411
#*
2412
my ($withAdmins, $order_by_nickname, $excludeID, $start) = @_; # include admins? (optional) && sort by nickname? (optional) && exclude a user ID (optional) && start at (default = 0)
2413
if (not $start or $start < 0) { $start = 0; }
2414
if (not $withAdmins) { $withAdmins = 0; }
2415
2416
my $sql = "select ID from users";
2417
$sql .= " where banned = '1'";
2418
if (not $withAdmins) { $sql .= " and security != '3'"; }
2419
if ($excludeID) { $sql .= " and ID != " . $DB->quote($excludeID); }
2420
if ($order_by_nickname) { $sql .= " order by nickname collate nocase"; }
2421
$sql .= " limit 1000 offset $start";
2422
my $results = sql_execute($sql, "Bc_sql.pm::get users"); # will always result in an array reference
2423
2424
my @users;
2425
if (ref $results eq "ARRAY") {
2426
foreach my $userRef (@$results) { push @users, $userRef->{ID}; }
2427
}
2428
2429
return @users; # a list of user ID's
2430
#usage: my @users = get_users();
2431
}
2432
2433
########################
2434
sub get_users_forDropdowns(;$$$$$) {
2435
#*
2436
# gets a list of all user IDs and nicknames
2437
# formatted in "id=name" pairs
2438
# with or without admins included
2439
# excludes banned users, too
2440
# optionally exclude a user ID
2441
# this function can generate massive
2442
# amounts of data being sent to a
2443
# client, use with extreme caution
2444
#
2445
# !lists only from $start to $start+1000
2446
#*
2447
my ($withAdmins, $order_by_nickname, $excludeID, $include_bans, $start) = @_; # include admins? (optional) && sort by nickname? (optional) && exclude a user ID (optional) && include banned accounts (optional) && start at index (defaults to 0)
2448
if ($start < 0 or not Bc_misc::a_number($start)) { $start = 0; }
2449
2450
my $sql = "select ID, nickname from users";
2451
#if (not $include_bans) { $sql .= " where banned = '1'"; }
2452
if (not $withAdmins) {
2453
if (User::isUserSuperAdmin()) {
2454
# ??
2455
} elsif (User::isUserAdmin()) {
2456
$sql .= " where security != " . $DB->quote(get_security("SuperAdministrator"));
2457
} elsif (User::isUserModerator()) {
2458
$sql .= " where security != " . $DB->quote(get_security("Moderator"));
2459
$sql .= " and security != " . $DB->quote(get_security("Administrator"));
2460
$sql .= " and security != " . $DB->quote(get_security("SuperAdministrator"));
2461
}
2462
} else {
2463
if (User::isUserModerator() and not User::isUserAdmin()) {
2464
$sql .= " where security < " . $DB->quote(get_security("Moderator"));
2465
}
2466
}
2467
2468
if ($excludeID) { $sql .= " and ID != " . $DB->quote($excludeID); }
2469
if ($order_by_nickname) { $sql .= " order by nickname collate nocase"; }
2470
$sql .= " limit 1000";
2471
if ($start) { $sql .= " offset $start"; }
2472
my $results = sql_execute($sql, "Bc_sql.pm::get_users_forDropdowns"); # will always return an array reference
2473
2474
my @users;
2475
# we will check if $results is an array reference anyway, even though we shouldn't need to!
2476
if (ref $results eq "ARRAY") {
2477
foreach my $userRef (@$results) {
2478
if ($userRef->{ID} ne get_constant("SITE_ADMIN")) { push @users, "$userRef->{ID}=$userRef->{nickname}"; }
2479
}
2480
}
2481
2482
return @users; # a list of user ID's
2483
#usage: my @users = get_users_forDropdowns();
2484
}
2485
2486
########################
2487
sub get_user_count(;$) {
2488
#*
2489
# returns a number of accounts
2490
# with or without admins included
2491
#*
2492
my ($withAdmins) = @_; # include admins? (optional)
2493
2494
my $sql = "select count(*) as C from users";
2495
if (not $withAdmins) {
2496
# okay, so the user editor is accessible to moderators
2497
# however, we want to limit who they can edit (such as other
2498
# moderators or higher security level users).
2499
if (User::isUserModerator() and not User::isUserAdmin()) {
2500
$sql .= " where security<" . get_security("Moderator");
2501
} else {
2502
$sql .= " where security<" . get_security("SuperAdministrator");
2503
}
2504
}
2505
2506
my $result = sql_execute($sql, "get user count");
2507
my $rv = 0;
2508
2509
if (ref $result eq "HASH") { $rv = $result->{C}; }
2510
#$rv = $sql;
2511
2512
return $rv; # a user count
2513
#usage: my $uCount = get_user_count();
2514
}
2515
2516
2517
########################################################################
2518
########################################################################
2519
###
2520
### the following are "msg_" functions
2521
###
2522
########################################################################
2523
########################################################################
2524
2525
2526
########################
2527
sub fma_exists($$) {
2528
#*
2529
# to determine if $to_uid has an unreciprocated fma
2530
# from $from_uid (there can and should only be 0 or 1)
2531
#*
2532
my ($from_uid, $to_uid) = @_; # a from UID && a to UID
2533
my $rv = 0;
2534
2535
my $sql = "select * from fuck_alerts where to_UID=" . $DB->quote($to_uid) . " and from_UID=" . $DB->quote($from_uid) . " and reciprocated='1' and ignored='1'";
2536
my $results = sql_execute($sql, "Bc_sql.pm::fma exists");
2537
2538
if (ref $results eq "HASH") { $rv = $results; }
2539
2540
return $rv; # 1 if unreciprocated fma exists or 0 if not
2541
#usage: if (not fma_exists($fuid, $tuid)) { print "no such fma"; }
2542
}
2543
2544
########################
2545
sub gift_exists($) {
2546
#*
2547
# to determine if gift id $gid exists or not
2548
#*
2549
my ($gid) = @_; # a gift ID
2550
my $rv = 0;
2551
my $sql = "select ID from gifts where ID = " . $DB->quote($gid);
2552
my $results = sql_execute($sql, "Bc_sql.pm::gift exists");
2553
2554
if (ref $results eq "HASH") { $rv = 1; }
2555
2556
return $rv; # 1 if gift exists or 0 if not
2557
#usage: if (gift_exists($gid)) { print "no such gift"; }
2558
}
2559
2560
########################
2561
sub msg_exists($) {
2562
#*
2563
# determines if there are any messages
2564
# in the user's inbox (read and unread)
2565
#*
2566
my ($msgid) = @_; # msgid to look up
2567
2568
my $sql = sql_execute("select * from messages where ID=". $DB->quote($msgid), "Bc_sql.pm::msg exists");
2569
my $rv = 0;
2570
if (ref $sql eq "ARRAY") {
2571
if (@$sql) { $rv = $sql; }
2572
} elsif (ref $sql eq "HASH") {
2573
$rv = $sql;
2574
}
2575
2576
return $rv; # 1 (exists) or 0 (does not exist)
2577
#usage: if (not msg_exists($msgid)) { print "msg is not in DB"; }
2578
}
2579
2580
########################
2581
sub msgs_exist($$) {
2582
#*
2583
# lists unread messages IDs for a given UID
2584
#*
2585
my ($uid) = @_; # the uid to look up
2586
2587
if (user_exists($uid)) {
2588
my $sql = sql_execute("select * from messages where from_ID = " . $DB->quote($uid), "Bc_sql.pm::msgs exist");
2589
if ($sql) {
2590
my @msgs = @$sql;
2591
2592
return @msgs; # a list of unread msg ID's
2593
} else {
2594
return 0; # no unread msgs
2595
}
2596
} else {
2597
return 0; # no such user
2598
}
2599
#usage: my @msgs = msgs_exist($uid);
2600
}
2601
2602
2603
########################################################################
2604
########################################################################
2605
###
2606
### the following are "is_" functions
2607
###
2608
########################################################################
2609
########################################################################
2610
2611
2612
########################
2613
sub is_debuggerAllowed(;$) {
2614
#*
2615
# determines if $uid has access to <a href='/debug.pl'>DeBugger</a>
2616
#*
2617
my ($uid) = @_; # uid (optional, default = $LOGGEDIN)
2618
if (not $uid) { $uid = $LOGGEDIN; }
2619
my $rv = 0;
2620
2621
if ($uid) {
2622
if ($DB) {
2623
my $sql = "select * from debugger_allowed where UID=" . $DB->quote($uid);
2624
my $r = sql_execute($sql, "is debugger allowed");
2625
2626
if (ref $r eq "HASH") {
2627
if ($r->{UID} eq $uid) { $rv = 1; }
2628
}
2629
else {
2630
$rv = "Not in Allow List";
2631
}
2632
}
2633
}
2634
else {
2635
$rv = "invalid UID (not loggedin?)";
2636
}
2637
2638
return $rv; # 1 if allowed, or 0 if not
2639
#usage: my $debugger_allowed = is_debuggerAllowed();
2640
}
2641
2642
########################
2643
sub get_flag_data($) {
2644
#*
2645
# determines if something
2646
# is flagged or not
2647
#*
2648
my ($id) = @_; # flag id
2649
my $rv = 0;
2650
my $sql = "select * from flagged where ID=" . $DB->quote($id);
2651
my $r = sql_execute($sql, "get flag data");
2652
if (ref $r eq "HASH") { $rv = $r; }
2653
2654
return $rv; # a hash reference to flagged data, or 0
2655
#usage: my $fdata = get_flag_data($flag_id)) { ... }
2656
}
2657
2658
########################
2659
sub get_flagged(;$) {
2660
#*
2661
# returns a list of all rows in flagged table
2662
# so long as the status is not "completed" or
2663
# "deleted"
2664
#*
2665
my ($all) = @_; # ignore status (optional, default = 0 = don't ignore status)
2666
my $sql = "select * from flagged";
2667
if (not $all) {
2668
$sql .= " where not status='deled' and not status='resolved'";
2669
# hm. "status" should not be hard-coded like this. ought to
2670
# convert it to "constants" (very handy if done right)
2671
}
2672
my $rv = sql_execute($sql, "Bc_sql::get_flagged($all)", 1); # always returns an array reference
2673
2674
if (@$rv == 0) { $rv = undef; }
2675
2676
return $rv; # an array reference of hash references to all flagged data, or undef
2677
#usage: my $fdata = get_flag_data($flag_id)) { ... }
2678
}
2679
2680
########################
2681
sub is_flagged($$$) {
2682
#*
2683
# determines if something
2684
# is flagged or not
2685
# returns 0 if item not flagged, or returns a reference to a hash of the flagged data
2686
#*
2687
my ($uid, $cid, $ctype) = @_; # flagged user id && content ID && content type (m=message, n=nickname, d=description, i=image)
2688
2689
my $sql = "select * from flagged where ";
2690
$sql .= " UID=" . $DB->quote($uid); # id of user BEING flagged
2691
$sql .= " and content_ID=" . $DB->quote($cid); # id of content
2692
$sql .= " and type=" . $DB->quote($ctype); # type of content
2693
$sql .= " and not status='rectified'";
2694
$sql .= " and not status='invalid'";
2695
$sql .= " and not status='trashed'";
2696
2697
my $results = sql_execute($sql, "Bc_sql.pm::is_flagged");
2698
my $rv = 0;
2699
if (ref $results eq "HASH") { $rv = $results; }
2700
2701
return $rv; # a hash reference to flagged data, or 0
2702
#usage: if (is_flagged("123", "m")) { ... }
2703
}
2704
2705
########################
2706
sub is_friend($$) {
2707
#*
2708
# again, kinda obvious
2709
#*
2710
my ($uid, $fid) = @_; # uid && friend's uid
2711
2712
my $sql = "select * from friends where UID = " . $DB->quote($uid) . " and FID = " . $DB->quote($fid);
2713
my $results = sql_execute($sql, "Bc_sql.pm::is friend");
2714
if ($results) {
2715
return 1; # if supplied FID is a friend of UID
2716
} else {
2717
return 0; # if supplied FID is not a friend of UID
2718
}
2719
#usage: if (is_friend($LOGGEDIN, $fid)) { ... }
2720
}
2721
2722
########################
2723
sub is_badname($) {
2724
#*
2725
# determines if a given word is "bad" or not
2726
# returns 0 if not, otherwise, returns 1
2727
#*
2728
my ($n) = @_; # a name
2729
2730
my $sql = "select * from badnames";
2731
my $badnames = sql_execute($sql, "Bc_sql.pm::is_badname", 1);
2732
my $rv = 0;
2733
2734
if (@$badnames) {
2735
foreach my $name (@$badnames) {
2736
my $badname = $name->{name};
2737
if ($n =~ /\Q$badname/i) { $rv = 1; } # name is BAAAAAAD!!!
2738
}
2739
}
2740
2741
return $rv; # 1 when name is "bad" or 0 when not "bad"
2742
#usage: if (is_badname($nn)) { ... }
2743
}
2744
2745
2746
########################################################################
2747
########################################################################
2748
###
2749
### the following are other or misc functions
2750
###
2751
########################################################################
2752
########################################################################
2753
2754
2755
########################
2756
sub in_maint() {
2757
#*
2758
# determines if website is in maintenence mode or not
2759
# a return value of 1 means the site is undergoing
2760
# maintenence, and 0 means not, of course
2761
#*
2762
#@_; # (no parameters)
2763
my $rv = 0;
2764
2765
my $sql = "select * from maint";
2766
my $result = sql_execute($sql, "Bc_sql.pm::in maint");
2767
if (ref $result eq "HASH") {
2768
# $result will be a hash reference
2769
if ($result->{value} eq 2) { $rv = 1; }
2770
}
2771
2772
return $rv; # 1 if in maintenance mode, or 0 if not
2773
#usage: if (in_maint()) { print "undergoing maint"; exit 1; }
2774
}
2775
2776
########################
2777
sub get_city_id($) {
2778
#*
2779
# to return just the city ID of a given set of coords
2780
#*
2781
my ($loc) = @_; # a location (like 19-76)
2782
$loc =~ s/^(.)*-//;
2783
2784
return $loc; # the city ID
2785
#usage: my $cID = get_city_id($ustats{location});
2786
}
2787
2788
########################
2789
sub get_country_id($) {
2790
#*
2791
# to return just the country ID of a given set of coords
2792
#*
2793
my ($loc) = @_; # a location (like 19-76)
2794
$loc =~ s/-(.)*$//;
2795
2796
return $loc; # the country ID
2797
#usage: my $cID = get_country_id($ustats{location});
2798
}
2799
2800
########################
2801
sub get_country_id_byName($) {
2802
#*
2803
# to return the country ID for a given country name
2804
#*
2805
my ($name) = @_; # the name of the country to retrieve an ID for
2806
my $ID = 0;
2807
my $sql = "select ID from countries where name like " . $DB->quote($name);
2808
my $results = sql_execute($sql, "Bc_sql.pm::get country id by name");
2809
# we should only have one result
2810
if (ref $results eq "HASH") {
2811
if ($results->{ID}) {
2812
$ID = $results->{ID};
2813
}
2814
}
2815
2816
return $ID; # the country name's ID (ie: 31)
2817
#usage: my $countryID = get_country_id_byName("Canada");
2818
}
2819
2820
########################
2821
sub get_profile_views_count($) {
2822
#*
2823
# this will return the number of times a user's profile
2824
# has been viewed
2825
#*
2826
my ($uid) = @_; # a uid
2827
2828
my $sql = "select count from profile_views where UID = " . $DB->quote($uid);
2829
my $results = sql_execute($sql, "Bc_sql.pm::get profile views count");
2830
my $rv = 1;
2831
if (not $results) {
2832
$rv = 0;
2833
} else {
2834
# this ought to be a hash ref
2835
if (ref $results eq "HASH") {
2836
$rv = $results->{count};
2837
} else {
2838
$rv = 0;
2839
}
2840
}
2841
2842
return $rv; # an integer
2843
#usage: my $pvCount = get_profile_views_count($uid);
2844
}
2845
2846
2847
########################################################################
2848
########################################################################
2849
###
2850
### the following are "set_" functions
2851
###
2852
########################################################################
2853
########################################################################
2854
2855
2856
########################
2857
sub set_config($$$) {
2858
#*
2859
# this will take the data supplied in $arrayRef
2860
# and dump it into the table $cfg points to (like 'styles')
2861
# $arrayRef will be a list of hash references
2862
# each hash will contain only two keys
2863
# "ID", "value"
2864
# with their respective values set appropriately
2865
#*
2866
my ($cfg, $arrayRef) = @_; # a cfg name (like 'styles') && and a reference to an array of hash references
2867
my $rv = 1;
2868
2869
# before we do anything else, we must determine if $cfg is a valid table within the db
2870
my $testSQL = "select * from " . $DB->quote($cfg) . " order by value collate nocase";
2871
my $testResults = sql_execute($testSQL, "Bc_sql.pm::set config, 1");
2872
if ($testResults) {
2873
# ok, the table exists
2874
# now, update the data!
2875
if (ref $arrayRef eq "ARRAY") {
2876
foreach my $hashRef (@$arrayRef) {
2877
# we could have an existing "value"
2878
# or we could be adding a new one
2879
# we already have the orig data in $testResults
2880
foreach my $testRef (@$testResults) {
2881
}
2882
my $sql = "update " . $DB->quote($cfg) . " set";
2883
$sql .= " value=" . $DB->quote($hashRef->{value});
2884
$sql .= " where ID = " . $DB->quote($hashRef->{ID});
2885
2886
my $updated = sql_execute($sql, "Bc_sql.pm::set config, 2");
2887
if (not $updated) { $rv--; }
2888
}
2889
}
2890
}
2891
2892
return $rv; # 1 for success or 0 (or lower) for failure
2893
#usage: my $cfg_set = set_config();
2894
}
2895
2896
########################
2897
sub set_constant($$) {
2898
#*
2899
# to set a 'constant'
2900
#*
2901
my ($name, $value) = @_; # a constant's name && a value to set the constant to
2902
my $rv = 0;
2903
2904
my $testSQL = "select * from constants where name = " . $DB->quote($name);
2905
my $testResults = sql_execute($testSQL, "Bc_sql.pm::set constant");
2906
if ($testResults) {
2907
# ok, the constant name exists
2908
# now, update the data!
2909
my $updateSQL = "update constants set";
2910
$updateSQL .= " value = " . $DB->quote($value);
2911
$updateSQL .= " where name = " . $DB->quote($name);
2912
}
2913
2914
return $rv; # 1 for success or 0 (or less) for failure
2915
#usage: my $results = set_constant("QUERY_PAGE", $value);
2916
}
2917
2918
########################
2919
sub ipn_exists($) {
2920
#*
2921
# to determine if a paypal IPN is already in the DB
2922
#*
2923
my ($txn_id) = @_; # a txn_id (eg: 194884645)
2924
my $rv = 0;
2925
2926
my $testSQL = "select * from paypal where txn_id = " . $DB->quote($txn_id);
2927
my $testResults = sql_execute($testSQL, "Bc_sql.pm::ipn exists");
2928
if (ref $testResults eq "HASH") {
2929
$rv = 1;
2930
} elsif (ref $testResults eq "ARRAY") {
2931
if (@$testResults) {
2932
# this should NEVER happen, since there can be only one!
2933
# but, just in case, we'll return -1
2934
$rv = -1;
2935
}
2936
}
2937
2938
return $rv; # 0 if txn_id does not yet exist. otherwise, 1 (or -1 in the case of many results)
2939
#usage: print "no IPN" if (not ipn_exists($txn_id));
2940
}
2941
2942
########################
2943
sub validate_new_user_data($;$) {
2944
#*
2945
# to determine if a hash reference of "new user data"
2946
# contains data in all the needed fields, and verifies
2947
# the data in each field conforms to the database
2948
# requirements.
2949
#*
2950
my ($dataRef, $ignore_nickname) = @_; # a reference to a hash of user data && ignore nickname
2951
my $rv = 1; # assume the new data is valid
2952
2953
my $NUM_FIELDS = 34;
2954
2955
# the first thing to do: check if $dataRef is a hash reference!
2956
if (ref $dataRef eq "HASH") {
2957
# now, make sure there are exactly $NUM_FIELDS in the hash!
2958
if (keys %$dataRef ne $NUM_FIELDS) { $rv = 0; }
2959
2960
# now, check all of the other fields
2961
# there are a TOTAL of $NUM_FIELDS keys
2962
# password can be any characters, but cannot be less than 4 characters
2963
# ensure bday year = (this year - 18)
2964
# month = (this month or "lower")
2965
# day = (this day, or "lower")
2966
# the description can be safely ignored
2967
# given location must be validated! lol 999-999 is not valid
2968
# most of the remaining fields are mainly numeric
2969
# those that aren't numeric fields (like "enrolled") need to be validated individually
2970
2971
# validate password
2972
if (length($dataRef->{password}) < 4) { $rv = -1; }
2973
2974
# validate ID's
2975
if (not Bc_misc::valid_hex($dataRef->{ID})) { $rv = -2; }
2976
#if (not valid_ccid($dataRef->{CCID})) { $rv = -3; }
2977
if (not theme_exists($dataRef->{TID})) { $dataRef->{TID} = "203537B0FF"; }
2978
2979
# validate lastip
2980
if (not valid_ip($dataRef->{lastip})) { $rv = -5; }
2981
2982
# validate dates
2983
if (not Date::valid_date($dataRef->{dob})) { $rv = -6; }
2984
if (not Date::valid_date($dataRef->{enrolled})) { $rv = -7; }
2985
if (not Date::valid_date($dataRef->{subscription_date})) { $rv = -8; }
2986
2987
# validate location
2988
if (not valid_location($dataRef->{location})) { $rv = -9; }
2989
2990
# validate "config" values
2991
if (not valid_config("membership_types", $dataRef->{subscription_type})) { $rv = -10; }
2992
if (not valid_config("yesno", $dataRef->{subscriber})) { $rv = -11; }
2993
if (not valid_config("yesno", $dataRef->{banned})) { $rv = -12; }
2994
if (not valid_config("yesno", $dataRef->{security})) { $rv = -13; }
2995
if (not valid_config("yesno", $dataRef->{showbday})) { $rv = -14; }
2996
if (not valid_config("races", $dataRef->{race})) { $rv = -15; }
2997
if (not valid_config("genders", $dataRef->{gender})) { $rv = -16; }
2998
if (not valid_config("orientations", $dataRef->{orientation})) { $rv = -17; }
2999
if (not valid_config("yesno", $dataRef->{drugs})) { $rv = -18; }
3000
if (not valid_config("yesno", $dataRef->{wheels})) { $rv = -19; }
3001
if (not valid_config("yesno", $dataRef->{can_host})) { $rv = -20; }
3002
if (not valid_config("yesno", $dataRef->{drinker})) { $rv = -21; }
3003
if (not valid_config("yesno", $dataRef->{smoker})) { $rv = -22; }
3004
if (not valid_config("styles", $dataRef->{seeking})) { $rv = -23; }
3005
if (not valid_config("genders", $dataRef->{seeking_gender})) { $rv = -24; }
3006
if (not valid_config("erections", $dataRef->{erection})) { $rv = -25; }
3007
if (not valid_config("busts", $dataRef->{bust})) { $rv = -26; }
3008
if (not valid_config("eyes", $dataRef->{eye_clr})) { $rv = -27; }
3009
if (not valid_config("hair", $dataRef->{hair_clr})) { $rv = -28; }
3010
if (not valid_config("weights", $dataRef->{weight})) { $rv = -29; }
3011
if (not valid_config("heights", $dataRef->{height})) { $rv = -30; }
3012
if (not valid_config("bodies", $dataRef->{body})) { $rv = -31; }
3013
3014
# now, remove html tags from nickname and email and description
3015
my $nohtml = HTML::Restrict->new();
3016
my $nn_processed = $nohtml->process($dataRef->{nickname});
3017
my $desc_processed = $nohtml->process($dataRef->{description});
3018
my $email_processed = $nohtml->process($dataRef->{email});
3019
if ($nn_processed ne $dataRef->{nickname}) { $rv = -32; }
3020
if ($email_processed ne $dataRef->{email}) { $rv = -33; }
3021
if ($desc_processed ne $dataRef->{description}) { $rv = -34; }
3022
3023
# now, ensure the nickname is not in use (or banned or not valid), and contains no html tags
3024
if (not $ignore_nickname) {
3025
my $id = User::get_uid_byNickname($nn_processed);
3026
if ($id) { $rv = -35; }
3027
}
3028
if (is_badname($nn_processed)) { $rv = -36; }
3029
3030
# and, finally, validate the email address!
3031
# if (User::valid_email($dataRef->{email}) ne 1) { $rv = -34; }
3032
3033
# and the description, as noted above, needs no validation at this time
3034
# perhaps later we can ensure no email addresses or phone numbers have been entered?
3035
} else {
3036
$rv = -404; # $dataRef is not a hash reference
3037
}
3038
3039
return $rv; # a scalar (1 if $dataRef has valid user info, or <= 0 if not)
3040
#usage: if (validate_new_user_data(\%newData)) { print "new user data is valid"; }
3041
}
3042
3043
########################
3044
sub valid_id($) {
3045
#*
3046
# determines if an ID contains only characters used in base 15 (hex) numbers
3047
# that is: 0-9 and A-F
3048
# if id is in db already, false is returned
3049
#*
3050
my ($id) = @_; # an ID
3051
my $rv = 1;
3052
3053
# first, lowercase $id
3054
if ($id) {
3055
# now, check the db for if the id exists or not
3056
my $id_sql = "select ID from users where ID=" . $DB->quote($id);
3057
my $result = sql_execute($id_sql, "Bc_sql.pm::valid id");
3058
if (ref $result eq "HASH") { $rv = 0; }
3059
elsif (ref $result eq "ARRAY") { if (@$result) { $rv = 0; } }
3060
3061
# if $rv wasn't changed, then check the id for valid characters
3062
if ($rv eq 1) {
3063
# let's do this like we do the email address check
3064
# remove valid chars, if the length of the ID is not 0
3065
# then the ID is not valid
3066
$id =~ s/[0-9]//g;
3067
$id =~ s/[a-f]//ig;
3068
if (length $id ne 0) { $rv = 0; }
3069
}
3070
} else {
3071
$rv = 0;
3072
}
3073
3074
return $rv; # 1 if valid, or 0 if not
3075
#usage: if (valid_id($)) { print "ID is acceptable"; }
3076
}
3077
3078
########################
3079
sub valid_tid($) {
3080
#*
3081
# determines if an ID contains only characters used in base 15 (hex) numbers
3082
# that is: 0-9 and A-F
3083
# if tid is in db already, false is returned
3084
#*
3085
my ($id) = @_; # an ID
3086
my $rv = 1;
3087
3088
# first, lowercase $id
3089
if ($id) {
3090
# now, check the db for if the theme id exists or not
3091
my $id_sql = "select ID from themes where ID=" . $DB->quote($id);
3092
my $result = sql_execute($id_sql, "Bc_sql.pm::valid tid");
3093
if (ref $result eq "HASH") { $rv = 0; }
3094
if (ref $result eq "ARRAY") { $rv = 0 if @$result; }
3095
3096
# if $rv wasn't changed, then check the id for valid characters
3097
if ($rv eq 1) {
3098
# let's do this like we do the email address check
3099
# remove valid chars, if the length of the ID is not 0
3100
# then the ID is not valid
3101
$id =~ s/[0-9]//g;
3102
$id =~ s/[a-f]//ig;
3103
if ($id) { $rv = 0; }
3104
}
3105
} else {
3106
$rv = 0;
3107
}
3108
3109
return $rv; # 1 if valid, or 0 if not
3110
#usage: if (valid_tid($)) { print "TID is acceptable"; }
3111
}
3112
3113
########################
3114
sub valid_ip($) {
3115
#*
3116
# determines if an ID contains only characters used in base 15 (hex) numbers
3117
# that is: 0-9 and A-F
3118
#*
3119
my ($ip) = @_; # an IP address
3120
my $rv = 1;
3121
3122
# first, let's split the ip into it's four components
3123
#my @ipbits = split(/\./, $ip);
3124
$ip =~ s/\./-/g; # i don't get why i had to do this! splitting on . didn't work as expected!
3125
my @ipbits = split(/-/, $ip);
3126
3127
# @ipbits should contain exactly four elements
3128
if (@ipbits ne 4) {
3129
$rv = 0;
3130
#$rv = @ipbits;
3131
#$rv = $ip;
3132
} else {
3133
# now make sure the first element is between 1 and 255, inclusively
3134
if ($ipbits[0] < 1 or $ipbits[0] > 255) { $rv = 0; }
3135
if ($ipbits[1] < 0 or $ipbits[1] > 255) { $rv = 0; }
3136
if ($ipbits[2] < 0 or $ipbits[2] > 255) { $rv = 0; }
3137
if ($ipbits[3] < 0 or $ipbits[3] > 255) { $rv = 0; }
3138
}
3139
3140
return $rv; # 1 if valid, or 0 if not
3141
#usage: if (valid_ip($)) { print "IP is acceptable"; }
3142
}
3143
3144
########################
3145
sub valid_location($) {
3146
#*
3147
# to determine if the provided location exists in the database
3148
#*
3149
my ($location) = @_; # a "location" (eg: 31-1)
3150
my $rv = 0;
3151
3152
# so, grab the list...
3153
my $sql = "select * from cities";
3154
my $ref = sql_execute($sql, "valid location");
3155
if (ref $ref eq "ARRAY") {
3156
foreach my $ref (@$ref) {
3157
if ($ref->{coords} eq $location) { $rv = 1; last; }
3158
}
3159
}
3160
3161
return $rv; # 1 if location is valid, or 0 if not
3162
#usage: if (valid_location("31-1")) { print "lovely town!"; } else { print "bah, n'er heard of it"; }
3163
}
3164
3165
########################
3166
sub valid_config($$;$) {
3167
#*
3168
# to determine if the provided value exists in the provided "config" table
3169
#*
3170
my ($cfg, $val, $col) = @_; # a "config" table name (eg: orientations) && a value to compare against what's in the $cfg table && against what column (optional, default = "value")
3171
if (not $col) { $col = "value"; }
3172
my $rv = 0;
3173
3174
my $DEFUG = 0; # yes, deFug!
3175
3176
my @values = ();
3177
3178
{ my $results = get_config($cfg, $val, $col);
3179
if (ref $results eq "ARRAY") {
3180
# $results is an array reference with two or more hash references as elements
3181
# even if @$results is empty, copy it to @values
3182
@values = @$results;
3183
} else {
3184
# it's a hash reference
3185
push @values, $results;
3186
}
3187
}
3188
3189
# now make sure we have at least one value in @array
3190
if (@values) {
3191
# if there is at least one value, then loop through each
3192
# checking to see if the given value is in the valid values list
3193
foreach my $valid_value (@values) {
3194
if ($valid_value eq $val) { $rv = 1; }
3195
}
3196
}
3197
3198
if ($DEFUG) {
3199
return "debug enabled: $rv (got " . (@values) . " total values)";
3200
} else {
3201
return $rv; # 1 if the given value exists in the $cfg table, or 0 if not
3202
}
3203
#usage: my $cfgValid = valid_config("orientations", 1, "ID");
3204
}
3205
3206
########################
3207
sub get_new_theme_data() {
3208
#*
3209
# returns a reference to a hash of
3210
# default theme data intended to be
3211
# used when creating a new theme
3212
# via the theme editor in the site
3213
# administration zone
3214
#*
3215
#@_; # (no parameters)
3216
my $ref = sql_execute("select * from defaults where name='THEME'", "Bc_sql.pm::get new theme data");
3217
3218
# i know i stress one return statement, but this one kinda needs two
3219
if (ref $ref ne "HASH") {
3220
# this shouldn't ever happen, but you never know, right?
3221
return 0; # 0 on failure (shouldn't ever happen)
3222
} else {
3223
# alright! we got it
3224
# let's make some HASH!!
3225
my %rv =
3226
map { split(m'='x, $_, 2) }
3227
grep { m'='x }
3228
split(m'\n'x, $ref->{value});
3229
3230
return %rv; # a hash on success
3231
}
3232
#usage: my %td = get_new_theme_data($);
3233
}
3234
3235
########################
3236
sub get_debug_users() {
3237
#*
3238
# returns of UID's which have access to debug.pl
3239
#*
3240
#@_; # (no parameters)
3241
my @rv = ();
3242
3243
my $sql = "select * from debugger_allowed";
3244
my $result = sql_execute($sql, "Bc_sql->get_debug_users");
3245
3246
if (ref $result eq "HASH") { push @rv, $result->{UID}; }
3247
if (ref $result eq "ARRAY") {
3248
foreach my $ref (@$result) {
3249
push @rv, $ref->{UID};
3250
}
3251
}
3252
3253
return @rv; # an array
3254
#usage: my $listRef = get_debug_users;
3255
}
3256
3257
########################
3258
sub get_default_theme(;$) {
3259
#*
3260
# will return a TID based on gender of the loggedin user
3261
# (or, optionally, a specified UID)
3262
# if the user's TID is not valid, select
3263
# a tid from @ids based on gender (which will be 1 or 2)
3264
# $rv = $ids[$ustats{gender}]
3265
#*
3266
my ($uid) = @_; # a uid (optional, default=$LOGGEDIN)
3267
if (not $uid) { $uid = $LOGGEDIN; }
3268
3269
my $rv = 0;
3270
if ($DB) {
3271
my $sql = "select value from defaults where name='THEMES'";
3272
my $results = sql_execute($sql, "Bc_sql.pm::get default theme, 1");
3273
3274
if (ref $results eq "HASH") {
3275
my @ids = split("\n", $results->{value});
3276
if (@ids) {
3277
if ($uid) {
3278
my %ustats = User::get_user_stats($uid);
3279
# if the user is logged in, grab their theme ID!
3280
# if the theme ID is non-existent, or invalid (shouldn't happen, but maybe it could)
3281
# then select the theme ID according to gender.
3282
if (theme_exists($ustats{TID})) {
3283
$rv = $ustats{TID}; # . " - logged in and the user's selected theme ($ustats{TID}) is valid";
3284
# end if (theme_exists(...))
3285
} else {
3286
if ($ustats{gender}) {
3287
$rv = $ids[$ustats{gender}]; # . " - logged in, but the user's selected theme (\"$ustats{TID}\") is invalid";
3288
} else {
3289
$rv = $ids[0];
3290
}
3291
# end else of if (theme_exists(...))
3292
}
3293
# end if ($uid)
3294
} else {
3295
$rv = $ids[0]; # . " - not logged in";
3296
# end else of if ($LOGGEDIN)
3297
}
3298
} # end if (@ids)
3299
else {
3300
$rv = $ids[0]; #"0 - no theme IDs in defaults";
3301
} # end else of if (@ids)
3302
} # end if ref $results eq "HASH"
3303
else {
3304
$rv = -2;
3305
} # end else of if ref $results eq "HASH"
3306
#end if $DB
3307
} else {
3308
$rv = -1;
3309
# end else of if $DB
3310
}
3311
3312
$rv =~ s/\r|\n//g;
3313
return $rv; # a scalar
3314
#usage: my $tid = get_default_theme();
3315
}
3316
3317
########################
3318
sub new_msgid() {
3319
#*
3320
# to generate a completely unique MSGID
3321
# the MSGID will not be found in the database
3322
# the MSGID will always contain 10 digits
3323
#*
3324
#@_; # (no parameters)
3325
my $id = Bc_misc::new_id(10);
3326
while (msgid_exists($id)) { $id = new_id(10); }
3327
3328
return $id; # a unique MSGID
3329
#usage: my $new_msgid = new_msgid;
3330
}
3331
3332
########################
3333
sub new_uid(;$$$$) {
3334
#*
3335
# to generate a completely unique UID
3336
# the UID will not be found in the database
3337
# the UID will always contain 10 digits
3338
#*
3339
my ($numDigits, $addSymbols, $caseSensitive, $wholeAlphabet) = @_; # number of digits to return (optional, default = 10) && add symbols to the id (optional, default = 0) && case sensitive (optional, default = 0) && use whole alphabet (optional, default = 0)
3340
my $id = Bc_misc::new_id($numDigits, $addSymbols, $caseSensitive, $wholeAlphabet);
3341
while (user_exists($id)) { $id = Bc_misc::new_id($numDigits, $addSymbols, $caseSensitive, $wholeAlphabet); }
3342
3343
return $id; # a unique UID
3344
#usage: my $new_uid = new_uid;
3345
}
3346
3347
########################
3348
sub new_sid($) {
3349
#*
3350
# to generate a completely unique Session ID
3351
# theSTID will not be found in the database
3352
# the SID will always contain 256 digits
3353
#*
3354
#@_; # (no parameters)
3355
my $sid = Bc_misc::new_id(256);
3356
while (sid_exists($sid)) { $sid = new_id(256); }
3357
3358
return $sid; # a unique Session ID
3359
#usage: my $new_tid = new_sid();
3360
}
3361
3362
########################
3363
sub new_tid() {
3364
#*
3365
# to generate a completely unique TID
3366
# the TID will not be found in the database
3367
# the TID will always contain 10 digits
3368
#*
3369
#@_; # (no parameters)
3370
my $id = Bc_misc::new_id(10);
3371
while (theme_exists($id)) { $id = new_id(10); }
3372
3373
return $id; # a unique UID
3374
#usage: my $new_tid = new_tid();
3375
}
3376
3377
########################
3378
sub new_ccid() {
3379
#*
3380
# to generate a completely unique CCID
3381
# the CCID will not be found in the database
3382
# the CCID will always contain 10 digits
3383
#*
3384
#@_; # (no parameters)
3385
my $id = new_id(10);
3386
while (ccid_exists($id)) { $id = new_id(10); }
3387
3388
return $id; # a unique CCID
3389
#usage: my $new_ccid = new_ccid();
3390
}
3391
3392
########################
3393
sub ccid_exists($) {
3394
#*
3395
# to determine if a given CCID exists or not
3396
#*
3397
my ($id) = @_; # a ccid candidate
3398
my $sql = "select ID from ccinfo where ID=" . $DB->quote($id);
3399
my $results = sql_execute($sql, "Bc_sql.pm::ccid exists");
3400
my $rv = 0;
3401
if (ref $results eq "HASH") {
3402
# the ID exists;
3403
$rv = 1;
3404
} else {
3405
# the following should never happen, but JUST in case
3406
if (@$results) { $rv = 1; }
3407
}
3408
3409
return $rv; # 1 if ccid exists, or 0 if not
3410
#usage: if (ccid_exists($id)) { print "id exists!"; }
3411
}
3412
3413
########################
3414
sub msgid_exists($) {
3415
#*
3416
# to determine if a given MSGID exists or not
3417
#*
3418
my ($id) = @_; # a MSGID candidate
3419
my $sql = "select ID from messages where ID=" . $DB->quote($id);
3420
my $results = sql_execute($sql, "Bc_sql.pm::msgid_exists");
3421
my $rv = 0;
3422
if (ref $results eq "HASH") {
3423
# the ID exists;
3424
$rv = 1;
3425
} else {
3426
# the following should never happen, but JUST in case
3427
if (@$results) { $rv = 1; }
3428
}
3429
3430
return $rv; # 1 if msgid exists, or 0 if not
3431
#usage: if (msgid_exists($id)) { print "id exists!"; }
3432
}
3433
3434
########################
3435
sub ban_exists($) {
3436
#*
3437
# to determine if a given ban ID exists or not
3438
# ID, in this case, does <i>not</i> refer to a UID!
3439
#*
3440
my ($id) = @_; # a BID candidate
3441
my $sql = "select ID from bans where ID=" . $DB->quote($id);
3442
my $results = sql_execute($sql, "Bc_sql.pm::ban exists");
3443
my $rv = 0;
3444
if (ref $results eq "HASH") {
3445
# the ID exists;
3446
$rv = 1;
3447
} else {
3448
# the following should never happen, but JUST in case
3449
if (@$results) { $rv = 1; }
3450
}
3451
3452
return $rv; # 1 if ban id exists, or 0 if not
3453
#usage: if (ban_exists($id)) { print "id exists!"; }
3454
}
3455
3456
########################
3457
sub add_points(;$$) {
3458
#*
3459
# adds a specified number of coins to a
3460
# given user's account
3461
#*
3462
my ($uid, $pts) = @_; # a uid (optional, default = $LOGGEDIN) && num points to add (optional, default = 5)
3463
if (not $uid) { $uid = $LOGGEDIN; }
3464
if (not $pts or $pts == 0) { $pts = 5; }
3465
3466
my $rv = 0;
3467
3468
if (user_exists($uid)) {
3469
my $sql = "select * from coins where ID=" . $DB->quote($uid);
3470
my $results = sql_execute($sql, "Bc_sql.pm::add points");
3471
3472
if (ref $results eq "HASH") {
3473
# the ID has points
3474
$sql = "update coins set points=" . $DB->quote($results->{points} + $pts) . " where ID=" . $DB->quote($uid);
3475
$rv = 1 if sql_execute($sql, "add points");
3476
} else {
3477
# the ID has no points (or there's more than one record for this ID!)
3478
if (not @$results) {
3479
$sql = "insert into coins values (" . $DB->quote($uid) . ", " . $DB->quote($pts) . ")";
3480
if (sql_execute($sql, "Bc_sql.pm::add points")) { $rv = 1; }
3481
}
3482
}
3483
}
3484
3485
return $rv; # 1 if adding coins succeeded, or 0 if not
3486
#usage: if (add_points($id, 123)) { print "done!"; }
3487
}
3488
3489
########################
3490
sub inc_pviews($;$$) {
3491
#*
3492
# to track who visited who, basically
3493
# PID is the UID of the profile being viewed
3494
# VID is the UID of the visitor
3495
# if you don't supply VID, $LOGGEDIN will
3496
# be used inplace
3497
# AMT is by how much to increment the visit
3498
# count; this is here in case it's needed,
3499
# and should not be used in production
3500
# if VID is new visitor, AMT will be ignored
3501
#*
3502
my ($pid, $vid, $amt) = @_; # a profile UID && visitor UID (optional, default=$LOGGEDIN) && amount to inc by (optional, default=1)
3503
if (not $vid) { $vid = $LOGGEDIN; }
3504
if (not $amt) { $amt = 1; }
3505
3506
my $rv = 0;
3507
3508
if ($pid ne $vid and user_exists($pid) and user_exists($vid)) {
3509
my $sql = "select * from profile_views where PUID=" . $DB->quote($pid) . " and VUID=" . $DB->quote($vid);
3510
# vr = visitor results (should be ref to % or @)
3511
my $vr = sql_execute($sql, "Bc_sql.pm::inc_pviews");
3512
3513
if (ref $vr eq "HASH") {
3514
# the VID has visited
3515
# add one to the counter for PID
3516
$sql = "update profile_views set view_count=" . $DB->quote($vr->{view_count} + $amt) . " where PUID=" . $DB->quote($pid) . " and VUID=" . $DB->quote($vid);
3517
if (sql_execute($sql), "Bc_sql.pm::inc_pviews") { $rv = $vr->{view_count} + $amt; }
3518
} elsif (ref $vr eq "ARRAY") {
3519
if (not @$vr) {
3520
# add a new PID/VID and set count to 1
3521
$sql = "insert into profile_views values (";
3522
$sql .= $DB->quote($pid) . ", ";
3523
$sql .= $DB->quote($vid) . ", ";
3524
$sql .= "'1'";
3525
$sql .= ")";
3526
if (sql_execute($sql), "Bc_sql.pm - inc_pviews") { $rv = 1; }
3527
}
3528
}
3529
}
3530
3531
return $rv; # 1 when inc succeeds, or 0 if not
3532
#usage: if (inc_pviews($id)) { print "done!"; }
3533
}
3534
3535
########################
3536
sub visited($$) {
3537
#*
3538
# determines if a profile has been
3539
# visited by a given UID or not
3540
#*
3541
my ($pid, $vid) = @_; # profile UID && visitor UID
3542
my $sql = "select ID from profile_views where ID=" . $DB->quote($pid) . " and viewerID=" . $DB->quote($vid);
3543
my $results = sql_execute($sql, "Bc_sql.pm::inc_pviews");
3544
my $rv = 0;
3545
3546
if (ref $results eq "HASH") { $rv = 1; }
3547
3548
return $rv; # 1 when yes, or 0 when not
3549
3550
#usage: if (visited($pid, $vid)) { $output .= "visited"; }
3551
}
3552
3553
########################
3554
sub num_visitors(;$) {
3555
#*
3556
# counts up all the visits a specified
3557
# UID has had
3558
#*
3559
my ($uid) = @_; # a UID
3560
3561
my $rv = 0;
3562
3563
my $sql = "select * from profile_views where PUID=" . $DB->quote($uid);
3564
my $results = sql_execute($sql, "Bc_sql.pm::inc_pviews");
3565
3566
if (user_exists($uid)) {
3567
if (ref $results eq "HASH") { $rv = 1; } else { $rv = @$results; }
3568
}
3569
3570
return $rv; # a number
3571
#usage: my $numVists = num_visitors($uid);
3572
}
3573
3574
########################
3575
sub get_latest_memberships(;$) {
3576
#*
3577
# lists the "latest" memberships
3578
# each element will be a hash reference
3579
# to user stats
3580
#*
3581
my ($include_new_premium_accounts) = @_; # include premium accounts
3582
my @rv = ();
3583
3584
#select s1.LAST_UPDATE_DATE_TIME,
3585
# s1.SCHOOL_CODE,
3586
# s1.PERSON_ID
3587
#from SCHOOL_STAFF s1
3588
#inner join
3589
#(
3590
# select max(LAST_UPDATE_DATE_TIME) LAST_UPDATE_DATE_TIME,
3591
# SCHOOL_CODE
3592
# from SCHOOL_STAFF
3593
# group by SCHOOL_CODE
3594
#) s2
3595
# on s1.SCHOOL_CODE = s2.SCHOOL_CODE
3596
# and s1.LAST_UPDATE_DATE_TIME = s2.LAST_UPDATE_DATE_TIME;
3597
3598
my $compare = "= '1'";
3599
if ($include_new_premium_accounts) { $compare = "<= '999999'"; }
3600
3601
my $sql = <<END;
3602
SELECT *
3603
FROM
3604
( SELECT ID, DATE(enrolled) AS enrolled, enrolled
3605
FROM users
3606
WHERE subscription_type $compare
3607
ORDER BY enrolled DESC
3608
LIMIT 100
3609
) AS tmp
3610
ORDER BY enrolled DESC
3611
END
3612
3613
my $uids = sql_execute($sql, "get_latest_memberships");
3614
if ($uids) {
3615
if (ref $uids eq "HASH")
3616
{ push @rv, $uids; } else
3617
{ @rv = @$uids; }
3618
}
3619
3620
return @rv; # a list of UIDs (may be empty)
3621
#usage: my @latest_uids = get_latest_memberships();
3622
}
3623
3624
########################
3625
sub get_photo_name($;$) {
3626
#*
3627
# returns the name of a given photo ID
3628
#*
3629
my ($id) = @_; # a photo ID
3630
my $rv = 0;
3631
3632
my $sql = "select name from images where ID=" . $DB->quote($id);
3633
my $results = sql_execute($sql, "Bc_sql.pm::get_photo_name");
3634
3635
if (ref $results eq "HASH") { $rv = $results->{name}; }
3636
3637
return $rv; # a photo ID's name
3638
#usage: my $id = get_photo_name(35);
3639
}
3640
3641
########################
3642
sub get_photo_desc($;$) {
3643
#*
3644
# returns the description of a given photo ID
3645
#*
3646
my ($id) = @_; # a photo ID
3647
my $rv = 0;
3648
3649
my $sql = "select desc from images where ID=" . $DB->quote($id);
3650
my $results = sql_execute($sql, "Bc_sql.pm::get_photo_name");
3651
3652
if (ref $results eq "HASH") { $rv = $results->{desc}; }
3653
3654
return $rv; # a photo ID's description
3655
#usage: my $desc = get_photo_desc(35);
3656
}
3657
3658
########################
3659
sub sql_execute_gpt($;$$) {
3660
#*
3661
# runs an SQL statement on the supplied db.<br>
3662
3663
# db must be connected, and <a href='#sql_disconnect'>sql_disconnect</a> to
3664
# commit changes IF autocommit is disabled.<br>
3665
3666
# <br>when successful, will return:
3667
# - an array ref, or a hash ref depending on the # of results (can be overridden)
3668
# - otherwise, returns 0
3669
3670
# <br><div class='centered error' style='text-align: left;'> - this function does not and will NOT "sanitize" your query!
3671
# - this function is SLOW when executed repeatedly!
3672
# - <i>$noHashRef</i> returns an empty array when $DB->prepare($sql) fails
3673
# when query contains invalid table/field name(s))</div><br>
3674
#*
3675
my ($sql, $debug_caller, $asArrayRef) = @_; # an SQL statement && for debug purposes (optional) && assign <i>1</i> to always return array ref (optional)
3676
my $rv = 0;
3677
my ($p, $f, $l) = caller;
3678
my $c = "line $l of module $p\:\:$f";
3679
3680
if ($DB) {
3681
my $prept = $DB->prepare($sql) or die $DB->errstr . ":$sql";
3682
if (not $prept) {
3683
my $msg = "db prepare failed (sql_execute";
3684
if ($debug_caller) { $msg .= "->$debug_caller"; }
3685
$msg .= ") (DB filename: $curr_db_fn): " . $DB->errstr;
3686
if ($asArrayRef) {
3687
my @why_didnt_slash_open_and_close_parenthesis_work = ();
3688
# cuz i'm not doing this right?
3689
$rv = \@why_didnt_slash_open_and_close_parenthesis_work;
3690
} else {
3691
$rv = 0; # 0 when sql statement prepare failed (for any reason)
3692
# often, but not limited to, it's because of uniqueness conflict(s)
3693
# or bad table name or invalid number of fields, or the set values are
3694
# invalid. eg: "set values(NULL, code='123')", when it should just be
3695
# "set values(NULL, '123')"
3696
}
3697
#die $msg;
3698
}
3699
else {
3700
if ($sql =~ /^insert |^update |^delete |^set /i) {
3701
if (not $debug_caller) { $debug_caller = $c; }
3702
if ($DEBUG)
3703
{ $rv = $DB->do($sql) or die $DB->errstr . "->$debug_caller"; } else
3704
{ $rv = $DB->do($sql) or print Redir::error_redir(Bc_misc::referrer(), "$debug_caller->DB Error: " . $DB->errstr); }
3705
3706
if ($rv eq "0E0") { $rv = 0; } # no rows were affected
3707
} else {
3708
# Select statement
3709
$prept->execute();
3710
3711
# Fetch all results from the query as an array of hash references
3712
my @arr = ();
3713
while (my $row = $prept->fetchrow_hashref) {
3714
push @arr, $row;
3715
}
3716
3717
if ($asArrayRef) {
3718
$rv = \@arr; # Always return an array reference if requested
3719
} else {
3720
if (@arr == 1 and ref $arr[0] eq "HASH") {
3721
$rv = $arr[0]; # Return a hash reference if there is only one result
3722
} else {
3723
$rv = \@arr; # Return an array reference (can be a zero-element array)
3724
}
3725
}
3726
}
3727
}
3728
}
3729
3730
return $rv; # See description
3731
# usage: my $rv = sql_execute_gpt($sql, ": generated from myFunction");
3732
}
3733
3734
########################
3735
########################
3736
########################
3737
########################
3738
########################
3739
########################
3740
########################
3741
########################
3742
########################
3743
3744
########################
3745
sub _tests(;$) {
3746
#*
3747
# to test all <i>Pm::Bc_sql</i> functions
3748
#*
3749
my ($extended) = @_; # show extended data (optional)
3750
my $rv = "";
3751
my $test = "";
3752
my $test2 = "";
3753
my $test3 = "";
3754
my $test4 = "";
3755
my @atest = ();
3756
my %htest;
3757
3758
if ($DB) {
3759
$test = "SITE_NAME";
3760
$rv .= Html::display_debug_scalar("get_constant(\"$test\"): ", get_constant($test)) . Html2::br();
3761
3762
$test = $Bc_sql::LOGGEDIN;
3763
$rv .= Html::display_debug_scalar("user_exists(\"$test\"): ", user_exists($test)) . Html2::br();
3764
3765
@atest = get_errors();
3766
$rv .= Html::display_debug_scalar("get_errors()", \@atest, 1);
3767
3768
@atest = get_constants();
3769
$rv .= Html::display_debug_scalar("get_constants()", \@atest, 0);
3770
3771
$test = "superadministrator";
3772
$rv .= Html::display_debug_scalar("get_security(\"$test\"): ", get_security($test));
3773
3774
$test = "192.168.1.888";
3775
$rv .= Html::display_debug_scalar("valid_ip(\"$test\"): ", valid_ip($test));
3776
3777
%htest = get_constants_asHash();
3778
$rv .= Html::display_debug_scalar("\%htest", \%htest);
3779
} else {
3780
$rv .= "DB connection error!<br>\n";
3781
}
3782
3783
# now, we're gonna add on some other misc. data and tests
3784
$rv .= Html::display_debug_scalar("", $default_db_fn) . Html2::br();
3785
3786
@atest = get_users_forDropdowns(1);
3787
$rv .= Html::display_debug_scalar("get_users_forDropdowns(1)", \@atest);
3788
3789
$test2 = 0;
3790
$test = get_user_count($test2);
3791
$rv .= Html::display_debug_scalar("get_user_count($test2): ", $test) . Html2::br();
3792
3793
$rv .= Html::display_debug_scalar("get_login(): ", get_login()) . Html2::br();
3794
$test = "security";
3795
$test2 = 0;
3796
$rv .= Html::display_debug_scalar("sql_get_user_stat(\"$Bc_sql::LOGGEDIN\", \"$test\", $test2): ", sql_get_user_stat("$LOGGEDIN", "$test", $test2)) . Html2::br();
3797
3798
$test = get_errors_asHash();
3799
$rv .= Html::display_debug_scalar("get_errors_asHash()", $test) . Html2::br();
3800
3801
$test = "C45D640DB8";
3802
$rv .= Html::display_debug_scalar("theme_exists('$test')", theme_exists($test)) . Html2::br();
3803
$rv .= Html::display_debug_scalar("get_theme_data('$test')", get_theme_data($test)) . Html2::br();
3804
$rv .= Html::display_debug_scalar("get_default_theme('$Bc_sql::LOGGEDIN'): ", get_default_theme($Bc_sql::LOGGEDIN)) . Html2::br();
3805
3806
$test = "eyes";
3807
$rv .= Html::display_debug_scalar("get_config('$test', 1, 'ID')", get_config($test, 1, "ID")) . Html2::br();
3808
3809
$test = "eyes";
3810
$test2 = 1999;
3811
$test3 = "ID";
3812
$test4 = valid_config($test, $test2, $test3);
3813
$rv .= Html::display_debug_scalar(Html2::br() . "valid_config('$test', '$test2', '$test3'): ", $test4) . Html2::br();
3814
3815
return $rv; # a scalar of the results of all tests
3816
#usage: print _tests();
3817
}
3818
3819
1;