Source Code -

Pm/Bc_misc.pm

Copying Source is Forbidden

1453 lines of code

package Bc_misc;

# a module for miscellaneous subroutines

# <table border=0 cellpadding=0 cellspacing=0 width=100%><tr><td align=center><table class=error cellpadding=0 cellspacing=0><tr><td align=center>This is base code<hr style='background-image: none; background-color: #FF0000; width: 50%;'></td></tr><tr><td align=center>do not include any use statements like use Pm::Bc_chef</td></tr></table></td></tr></table>

#CHLOG

# CHANGE LOG

# ==========

# - May 12, 2021

# - Added change log

# - Tweaked a few subroutine descriptions

#CHLOG

use strict;

use warnings;

use CGI::Carp qw(fatalsToBrowser);

use Exporter;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

use CGI;

use URI::Escape;

use HTML::Clean;

use HTML::Restrict;

use File::Basename;

$VERSION = 1.00;

@ISA = qw(Exporter);

@EXPORT = qw(

get_param

referrer

add_param

shorten_str

spaces

$COOL_DOT

$cgi

);

@EXPORT_OK = qw(

_tests

a_number

a_or_an

add_numeric_suffix

add_param

add_zeros

byte_count

clear_spaces

commafied

fixthe

get_param

get_param_unfiltered

get_params

get_params_asArray

get_params_asHash

get_salt

hexDigit2Dec

isa_ArrayRef

isa_HashRef

minify_js

modulo

new_id

pluralize

pluralizable

random_numbers

redact

referrer

remove_param

shorten_str

spaces

to_hash

sanitize

valid_hex

word_as_possessive

$COOL_DOT

$cgi

);

########################

our $COOL_DOT = "•";

our $cgi = new CGI;

100

########################

101

102

########################

103

104

my $DEBUG_SPACES = 0;

105

106

########################

107

sub get_salt() {

108

109

# generates a string of two random characters for use in encrypting pwords

110

111

#@_; # (no parameters)

112

my $rv = join '', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64];

113

114

return $rv; # a scalar

115

#usage: my $salt = get_salt(); # can return stuff like "9." as the "salt"

116

}

117

118

########################

119

sub a_or_an($) {

120

121

# prepends "an" or "a" (and a space) to a word

122

# this function does not look at digits (like 18 or 80)

123

124

my ($word) = @_; # the word

125

my $an = "a";

126

if ($word =~ /^[aeiouh]/i) {

127

if ($word !~ /heterosexual|^[1-7]|^9/i) {

128

$an .= "n";

129

}

130

}

131

132

return "$an $word"; # a scalar

133

#usage: my $sentence = "I have " . a_or_an($word) . " for lunch!";

134

}

135

136

########################

137

sub add_numeric_suffix($) {

138

139

# adds st, nd, rd, or th to a number

140

141

my ($num) = @_; # the number to amend

142

143

# first, let's remove all leading 0's.

144

$num =~ s/^(0)*//;

145

if ($num) {

146

if ($num =~ /1[1|2|3]$/) { $num .= "th"; }

147

elsif ($num =~ /1$/) { $num .= "st"; }

148

elsif ($num =~ /2$/) { $num .= "nd"; }

149

elsif ($num =~ /3$/) { $num .= "rd"; }

150

else { $num .= "th"; }

151

} else {

152

$num = "0";

153

}

154

155

return $num; # scalar format of your number with a suffix (st, nd, rd, th)

156

#usage: my $num = add_numeric_suffix(18);

157

}

158

159

##############################

160

sub add_zeros($) {

161

162

# to insert a leading zero before any number that is 0 through 9

163

164

my ($num) = @_; # the number to modify

165

$num =~ s/^(0)*//; # remove any leading zeros

166

if ($num < 10 and $num >= 0) { $num = "0$num"; }

167

if ($num eq "0") { $num = "00"; }

168

169

return $num; # a scalar

170

#usage: my $modded_num = add_zeros($sum_num);

171

}

172

173

########################

174

sub commafied($) {

175

176

# to insert commas before every 3rd number (from the right)

177

# positive or negative numbers

178

179

my ($num) = @_; # the number to insert commas into!

180

181

my $negative = 0;

182

if ($num =~ /^-/) {

183

$negative = 1;

184

$num =~ s/^-//;

185

}

186

$num =~ s/^(0)*//; # strip LEADING zeros from given number!

187

$num =~ s/0/-/g; # convert zeros to dashes because reverse and/or split like to ignore zeros!

188

189

if ($num) {

190

my @digits = reverse split("", $num);

191

$num = "";

192

193

for (my $i = 0; $i < @digits; $i += 3) {

194

$num .= $digits[$i];

195

if ($digits[$i+1]) { $num .= $digits[$i+1]; }

196

if ($digits[$i+2]) { $num .= $digits[$i+2]; }

197

if ($i < (@digits - 3)) { $num .= ","; }

198

if ($i >= @digits) { last; }

199

}

200

201

#$num =~ s/,$//;

202

$num = join("", reverse split("", $num));

203

$num =~ s/-/0/g;

204

}

205

206

if ($negative) { $num = "-" . $num; }

207

208

return $num; # a number with commas added

209

#usage: my $prettyNum = commafied(1234567890);

210

}

211

212

########################

213

sub get_param($;$$) {

214

215

# gets the value of a given URL parameter name

216

217

my ($p, $escape, $noSanitize) = @_; # the URL parameter to retrieve && "uri_escape" the value && unsanitized data

218

my $rv = "";

219

220

if ($noSanitize)

221

{ $rv = scalar $cgi->param($p); } else

222

{ $rv = sanitize(scalar $cgi->param($p)); }

223

224

if (not $rv) {

225

foreach my $arg (@ARGV) {

226

if ($arg =~ s/$p\=//) { $rv = $arg; last; }

227

}

228

}

229

230

if ($rv and $escape) { $rv = uri_escape($rv); }

231

$rv =~ s/\r//g; # remove annoying \r from $rv

232

233

return $rv; # a scalar

234

#usage: my $page = get_param($QUERY_PAGE, 1);

235

}

236

237

########################

238

sub modulo($$) {

239

240

# calculate the remainder and the quotient of a given number

241

# returns an array where element 0 is the remainder and element 1 is the quotient

242

243

my ($number, $divisor) = @_; # the number && and what to divide the number by

244

245

my $remainder = $number % $divisor;

246

my $quotient = ($number - $remainder) / $divisor;

247

248

my @modulos = ($remainder, $quotient);

249

return @modulos; # an array containing the remainder and the quotient, respectively.

250

#usage: my @remquo = modulo(1234567890, 123);

251

}

252

253

##############################

254

sub new_id(;$$$$) {

255

256

# to randomly generate a multi-digit, hexidecimal "number"

257

# specify how many digits the number should have in $numDigits

258

# $numDigits defaults to 10 when absent or if it's < 4

259

# $numDigits capped at 4096

260

# $addSymbols and $wholeAlphabet effectively override hexidecimal

261

# output

262

263

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)

264

if (not $numDigits or $numDigits < 4) { $numDigits = 10; }

265

if ($numDigits > 4096) { $numDigits = 4096; }

266

my @set = ('0' ..'9', 'A' .. 'F');

267

if ($wholeAlphabet) { push @set, ('G' .. 'Z'); }

268

if ($caseSensitive) {

269

push @set, ('a' .. 'f');

270

if ($wholeAlphabet) { push @set, ('g' .. 'z'); }

271

}

272

if ($addSymbols) { push @set, ('!', '@', '#', '$', '%', '^', '&', '*', '(', ')', '-', '=', '_', '+', '~', '`', ',', '<', '.', '>', '/', '?', '[', '{', ']', '}', ';', ':', '\'', '"', '\\', '|'); }

273

my $uid = join '' => map $set[rand @set], 1 .. $numDigits;

274

275

return $uid; # a scalar

276

#usage: my $id = new_id(64);

277

}

278

279

########################

280

sub pluralizable($) {

281

282

# to pluralize any given word

283

# this will not account for ALL words!

284

# but, it will try.

285

286

# this function is not exactly meant to be used

287

# standalone. it's intended for use within the

288

# <a href="#pluralize">pluralize(...)</a> subroutine. nor is it a

289

# spell-checker!

290

291

# this function MAY return words in all lower case

292

# under some circumstances (like if the word is

293

# "Child").

294

295

# pluralizable will simply pluralize a word. the

296

# name of this function should be changed to

297

# plural_of.

298

299

# consonant y to ies

300

# sis to ses

301

# f to ves

302

# us to i

303

304

my ($word) = @_; # the word to examine

305

my $rv = 0; # assume it can't be, because MOST words can be.

306

307

# some words have special (??) plural versions

308

# when adding to this list, ensure all is lower-case!

309

my %specials = (

310

you => "you",

311

goose => "geese",

312

moose => "moose",

313

mouse => "mice",

314

joey => "joeys",

315

man => "men",

316

woman => "women",

317

child => "children",

318

tooth => "teeth",

319

foot => "feet",

320

person => "people",

321

sheep => "sheep",

322

fish => "fish",

323

deer => "deer",

324

species => "species",

325

aircraft => "aircraft",

326

phenomenon => "phenomena",

327

criterion => "criteria",

328

datum => "data",

329

cod => "cod",

330

salmon => "salmon",

331

cattle => "cattle",

332

scissors => "scissors",

333

trousers => "trousers",

334

pants => "pants",

335

jeans => "jeans",

336

337

roof => "roofs",

338

proof => "proofs",

339

chief => "chiefs",

340

341

stomach => "stomachs",

342

343

hero => "heroes",

344

potato => "potatoes",

345

tomato => "tomatoes",

346

volcano => "volcanoes",

347

348

is => "are",

349

);

350

351

# first, check if $word isn't a special word

352

if ($specials{lc($word)}) { $rv = $specials{lc($word)}; }

353

354

# if $word was NOT a special word, then $rv will still be 0

355

if (not $rv) {

356

$rv = $word;

357

358

if ($rv =~ /([a|e|i|o|u|h])y$/i) { $rv .= "s"; }

359

elsif ($rv =~ /(?![a|e|i|o|u]y)y$/i) { $rv =~ s/y$/ies/i; }

360

elsif ($rv =~ /sis$/i) { $rv =~ s/sis$/ses/i; }

361

elsif ($rv =~ /ch$|s$|sh$|x$|z$/i) { $rv .= "es"; }

362

elsif ($rv =~ /f$|fe$/i) { $rv =~ s/f$|fe$/ves/i; }

363

else {

364

$rv .= "s";

365

}

366

}

367

368

return $rv; # the plural of $word

369

#usage: print "i have 10 " . pluralizable("buddy") . "! \n";

370

}

371

372

########################

373

sub pluralize($$) {

374

375

# will pluralize a word if $num ne 1

376

377

my ($word, $num) = @_; # the word to pluralize & a number

378

379

# okay, the following line is for if the word ends in a consenant other than y (like library), or us (like octopus)

380

# there ARE rules to this shit. i'll weed them out as i go

381

382

if ($num ne 1) {

383

$word = pluralizable($word);

384

}

385

386

return $word; # your word, pluralized (perhaps)

387

#usage: print "you have $numBuds " . pluralize("Buddy", $numBuds) . "! \n";

388

}

389

390

##############################

391

sub random_numbers() {

392

393

# to generate a random number from

394

# 0 to 9,223,372,036,854,775,807

395

396

#@_; # (no parameters)

397

398

return int(rand(9223372036854775807)); # a number

399

#usage: my $code = random_numbers();

400

}

401

402

##############################

403

sub redact($;$) {

404

405

# to convert every character in a given string to a given

406

# character (default is 0x25CF - a solid round dot)

407

408

# if $char eq "strike", then str gets wrapped in a

409

# strikethrough HTML tag, and no char replacement

410

# occurs.

411

412

# if $char =~ s/^CSIS,//, then

413

# a background and foreground colour of black, and the text

414

# is converted to whatever char follows "CSIS," (eg: CSIS,x)

415

# this character can be a space, or omitted altogether!

416

# the string will be shortened to 3 characters

417

418

my ($str, $char) = @_; # the string to convert && replacement character (optional, default = 0x25CF)

419

if (not $char) { $char = chr(0x25CF); }

420

$str =~ s/(\n)*$//; # remove trailing new lines

421

422

if ($char eq "strike") {

423

$str = "<strike>$str</strike>";

424

} elsif ($char =~ s/^CSIS,//) {

425

if (not $char) { $char = chr(0x25CF); }

426

# and because this is an official redaction, let's

427

# "shorten" the string to just 3 characters!

428

$str = shorten_str($str, 3);

429

$str =~ s/./$char/g;

430

if ($char eq " ") { $str =~ s/ / /g; }

431

$str = "$str";

432

} else {

433

$str =~ s/./$char/g;

434

}

435

436

return $str; # a scalar

437

#usage: my $pw = redact(get_user_pw($uid), '-');

438

}

439

440

########################

441

sub shorten_str($$;$) {

442

443

# shortens $str to $len if the length of $str > $len

444

# optionally append an ellipsis to $str if it does get shortened

445

# the ellipsis effectively shortens $len by 3

446

447

my ($str, $len, $no_ellipsis) = @_; # the string to shorten && the length you want the string to be && append an ellipsis (...) or not (optional; default=0 meaning ellipsis will be added)

448

my $rv = $str;

449

450

# now, do we NEED to shorten $str?

451

if (length($str) > $len) {

452

if ($no_ellipsis) {

453

# do NOT append "..." to $rv

454

$rv = substr($str, 0, $len);

455

} else {

456

# appened "..." to $str

457

if (length($str) > $len-3) {

458

$rv = substr($str, 0, $len-3) . "...";

459

}

460

}

461

}

462

463

return $rv; # $str possibly shortened, with or without "..." appended

464

#usage: my $shortened = shorten_str($str, 10);

465

}

466

467

########################

468

sub word_as_possessive($) {

469

470

# appends ' or 's to a given $word

471

472

my ($word) = @_; # the word to possess!

473

if ($word =~ /s$/) {

474

# the word ends with s

475

$word .= "'";

476

} else {

477

# the word ends with something other than s

478

$word .= "'s";

479

}

480

481

return $word; # the word with ' or 's appended

482

#usage: my $linkText = word_as_possessive('James') . " Profile";

483

}

484

485

########################

486

sub get_params_asHash(;$) {

487

488

# to get the URL parameters, and package

489

# them into a tidy hash data structure.

490

491

# where each key = param name

492

# and value in key = param value

493

# eg: my %p = get_params_asHash();

494

# my $tab = $p{'tab'};

495

496

my ($separator) = @_; # separator (optional, default = &)

497

if (not $separator) { $separator = "&"; }

498

499

# build the hash

500

my %hash = map { split(m'='x, $_, 2) }

501

grep { m'='x }

502

split(m'&'x, get_params());

503

504

return %hash; # a hash of URL parameters

505

#usage: my %url_params = get_params_asHash();

506

}

507

508

########################

509

sub get_params_asArray(;$) {

510

511

# to get the URL parameters, and package

512

# them into a cute little list of URL

513

# parameter pairings where each element is

514

# name=value

515

516

my ($separator) = @_; # separator (optional, default = &)

517

if (not $separator) { $separator = "&"; }

518

519

# build the array

520

return split('\&', get_params()); # an array

521

#usage: my @url_params = get_params_asArray();

522

}

523

524

########################

525

sub get_params(;$) {

526

527

# to get the URL parameters, and package

528

# them into a handy little scalar. each param

529

# is separated by an "&"

530

531

# there are other functions to retrieve this

532

# same data as a hash or an array of parameters

533

534

# URL parameters are received already escaped

535

# for us by the client and is not directly

536

# altered in this subroutine.

537

538

my ($separator) = @_; # separator (optional, default = &)

539

if (not $separator) { $separator = "&"; }

540

541

# build the scalar

542

my $cgi = CGI->new();

543

my $params = join($separator, map { $_ . '=' . $cgi->param($_) } $cgi->param());

544

545

return $params; # a scalar

546

#usage: my $url_params = get_params();

547

}

548

549

########################

550

sub referrer() {

551

552

# to get the referring URL

553

# if the referring URL is empty, then / will

554

# be returned

555

556

#@_; # (no parameters)

557

my $rv = $ENV{HTTP_REFERER};

558

if (not $rv) { $rv = "/"; }

559

560

return $rv; # a scalar

561

#usage: print referrer();

562

}

563

564

########################

565

sub isHashRef($) {

566

567

# to determine if a scalar is a hash reference, or not

568

569

my ($candidate) = @_; # candidate reference

570

my $rv = 0;

571

572

if (ref $candidate eq "HASH") { $rv = 1; }

573

574

return $rv; # 1 when it's a reference or 0 if not

575

#usage: if (isHashRef($ref)) { print "it's a hash reference alright"; }

576

}

577

578

########################

579

sub isArrayRef($) {

580

581

# to determine if a scalar is an array reference, or not

582

583

my ($candidate) = @_; # candidate reference

584

my $rv = 0;

585

586

if (ref $candidate eq "ARRAY") { $rv = 1; }

587

588

return $rv; # 1 when it's a reference or 0 if not

589

#usage: if (isArrayRef($ref)) { print "it's an array reference alright"; }

590

}

591

592

########################

593

sub sanitize($) {

594

595

# to remove only the HTML from a string

596

# that is to say, <script> tags will be removed,

597

# but whatever is between <script> and </script>

598

# will not be removed.

599

600

my ($s) = @_; # a string of text

601

my $rv = 0;

602

603

if ($s) {

604

my $nohtml = HTML::Restrict->new();

605

my $processed = $nohtml->process($s);

606

if ($processed ne $s) { $rv = $processed; } else { $rv = $s; }

607

}

608

609

return $rv; # $s with HTML tags removed.

610

#usage: my $sanitized = sanitize($input);

611

}

612

613

########################

614

sub valid_hex($) {

615

616

# determines if an ID contains only characters used in base 15 (hex)

617

# that is: 0-9 and A-F

618

619

my ($s) = @_; # a string

620

my $rv = 1;

621

622

if ($s) {

623

# let's do this like we do the email address check

624

# remove valid chars, if the length of the ID is not 0

625

# then the ID is not valid

626

$s =~ s/[0-9]//g;

627

$s =~ s/[a-f]//ig;

628

if (length $s ne 0) { $rv = 0; }

629

} else {

630

$rv = 0;

631

}

632

633

return $rv; # 1 if valid, or 0 if not

634

#usage: if (valid_id($hexNum)) { print "valid hexidecimal number"; }

635

}

636

637

########################

638

sub clear_spaces($) {

639

640

# removes all sequences of two or more leading spaces

641

# and every line with only \n from a given string

642

643

my ($s) = @_; # the string to condense

644

645

my @spaces = split("\n", $s);

646

$s = "";

647

foreach my $space (@spaces) {

648

$space =~ s/^( )*//;

649

$s .= $space . "\n";

650

}

651

652

return $s; # a scalar

653

#usage: $output = clear_spaces($output);

654

}

655

656

########################

657

sub minify_js($) {

658

659

# goal is to remove all unnecessary stuff from js code

660

# for now, just converts all \n\n to \n

661

662

my ($s) = @_; # the string to condense

663

$s =~ s/\n\n/\n/g;

664

#$s =~ s/\n/ /g; # this breaks javascript?? why?

665

666

return $s; # a scalar with all \n's removed.

667

#usage: $output = minify_js($output);

668

}

669

670

########################

671

sub minify_html($) {

672

673

# goal is to remove all html from a string

674

# for now, just returns what was passed in

675

676

my ($s) = @_; # the string to condense

677

678

return $s; # a scalar with all \n's removed.

679

#usage: $output = minify_js($output);

680

}

681

682

########################

683

sub hexDigit2Dec($) {

684

685

# converts a SINGLE hexidecimal digit to decimal

686

# eg: C --> 12

687

688

my ($digit) = @_; # the digit to convert

689

$digit = uc($digit);

690

if ($digit eq "A") { $digit = 10; }

691

elsif ($digit eq "B") { $digit = 11; }

692

elsif ($digit eq "C") { $digit = 12; }

693

elsif ($digit eq "D") { $digit = 13; }

694

elsif ($digit eq "E") { $digit = 14; }

695

elsif ($digit eq "F") { $digit = 15; }

696

elsif ($digit eq "1" or $digit eq 1) { $digit = 1; }

697

elsif ($digit eq "2" or $digit eq 2) { $digit = 2; }

698

elsif ($digit eq "3" or $digit eq 3) { $digit = 3; }

699

elsif ($digit eq "4" or $digit eq 4) { $digit = 4; }

700

elsif ($digit eq "5" or $digit eq 5) { $digit = 5; }

701

elsif ($digit eq "6" or $digit eq 6) { $digit = 6; }

702

elsif ($digit eq "7" or $digit eq 7) { $digit = 7; }

703

elsif ($digit eq "8" or $digit eq 8) { $digit = 8; }

704

elsif ($digit eq "9" or $digit eq 9) { $digit = 9; }

705

else { $digit = 0; } # anything else will be seen as a zero

706

707

return $digit; # hexidecimal digit converted to decimal

708

#usage: $output = hexDigit2Dec("c");

709

}

710

711

########################

712

sub a_number($) {

713

714

# is it a number, or not?

715

716

my ($scalar) = @_; # the "number" to examine

717

my $it = $scalar;

718

719

if ($scalar) {

720

$it =~ s/^-//;

721

722

if ($it) {

723

$it =~ s/[0-9]//g; # remove all digits.

724

# if there's nothing left, it was a number

725

if (not $it) { $it = 1; } else { $it = 0; }

726

}

727

} else {

728

$it = 1;

729

}

730

731

return $it; # 1 when $scalar is a number, otherwise 0

732

#usage: if (a_number('abc123')) { ... }

733

}

734

735

########################

736

sub remove_param($$) {

737

738

# removes a parameter from a given url, if it exists

739

# and returns the results. given url is not affected

740

# !this is not likely bullet-proof!

741

742

my ($p, $u) = @_; # the parameter to remove (eg: "t") && the uri to remove $p from

743

$p =~ s/\=(.)*//; # just in case (but, a year or more later, i don't know why!)

744

my $rv;

745

746

my $DEBUG_REMOVE_PARAM = 0;

747

748

# beware. we could get just the params, or just a hash tag, or

749

# params and a hash tag, or

750

# a fully qualified url with or without params and/or hashtags!

751

# so how does one split a URL into it's three major components??

752

753

# 1 - https://www.google.ca/damn.html?bob=uncle#photos: hash is right. params contains hash. fn is right

754

# 2 - https://www.google.ca/damn.html?bob=uncle: hash eq $u. params is right. fn is right.

755

# 3 - https://www.google.ca/damn.html: hash, params, and fn are equal

756

# 4 - https://www.google.ca/damn.html#photos: hash is right. params and fn are equal and contain the hash tag

757

# 5 - ?bob=uncle#photos: hash is right, params contains hash, fn is empty

758

# 6 - bob=uncle#photos hash is right, params eq $u, fn eq $u

759

# 7 - ?bob=uncle hash eq $u, params is right, fn is empty

760

# 8 - #photos hash is right, params eq $u, fn eq $u

761

# 9 - bob=uncle hash eq $u, params eq $u, fn eq $u

762

# 10 - photos hash eq $u, params eq $u, fn eq $u

763

764

# did i get'm all?

765

# watch this, with my luck, this site will hit one i missed!

766

767

# so now how do we program the above???

768

769

my $fn = $u;

770

my $params = $u;

771

my $hash = $u;

772

773

$fn =~ s/\?.*//;

774

$params =~ s/.*\?//;

775

$hash =~ s/.*\#//;

776

777

my $rebuild = 0;

778

# where 0 = don't rebuild params

779

# 1 = rebuild params

780

781

if ($hash !~ /#/ and $params =~ /#/ and $fn !~ /#/ and $fn !~ /\?/) {

782

# 1

783

$rebuild = 1;

784

$rv = 1;

785

} elsif ($hash eq $u and $params !~ /#/ and $fn !~ /#/ and $fn !~ /\?/) {

786

# 2

787

$rebuild = 1;

788

$rv = 2;

789

} elsif ($hash eq $params and $hash eq $fn) {

790

# 3

791

$rv = $u;

792

} elsif ($hash and $params eq $fn and $params =~ /#/ and $fn =~ /#/) {

793

# 4

794

$rebuild = 1;

795

$rv = 4;

796

} elsif ($hash and $params =~ /#/ and not $fn) {

797

# 5

798

$rebuild = 1;

799

$rv = 5;

800

} elsif ($hash and $params eq $u and $fn eq $u) {

801

# 6

802

$rebuild = 1;

803

$rv = 6;

804

} elsif ($hash eq $u and $params and not $fn) {

805

# 7

806

$rebuild = 1;

807

$rv = 7;

808

} elsif ($hash and $params eq $u and $fn eq $u) {

809

# 8

810

$rv = $u;

811

} elsif ($hash eq $u and $params eq $u and $fn eq $u) {

812

# 9

813

$rebuild = 1;

814

$rv = 9;

815

} else {

816

# 10, and the others i likely missed at 525am!

817

$rv = $u;

818

}

819

820

if ($rebuild) {

821

$params =~ s/\#.*//;

822

my @params = split(/&/, $params);

823

my @new;

824

foreach my $param (@params) {

825

my ($n, $v) = split(/=/, $param);

826

if ($n ne $p) {

827

push @new, $param;

828

}

829

}

830

831

if ($fn ne $params) {

832

if ($fn) {

833

if ($u =~ /\?/) { $rv = $fn . "?"; } else { $rv = ""; }

834

} else {

835

$rv = "?";

836

}

837

$rv .= join("&", @new);

838

if ($hash and $hash ne $u) { $rv .= "#" . $hash; }

839

} else {

840

$rv = join("&", @new);

841

if ($hash and $hash ne $u) { $rv .= "#" . $hash; }

842

}

843

}

844

845

if ($DEBUG_REMOVE_PARAM) {

846

my $newurl = $rv;

847

$rv .= " \n";

848

$rv .= "orig url: $u \n";

849

$rv .= "new url: $newurl \n";

850

}

851

852

return $rv; # the URL with the parameter and associated value removed (if it existed)

853

#usage: my $r = remove_param("t", referrer());

854

}

855

856

########################

857

sub add_param($$$) {

858

859

# adds a parameter to a given url

860

# if the parameter already exists, it gets overwritten

861

# !this is not likely bullet-proof!

862

863

my ($param, $value, $url) = @_; # the parameter to add (eg: "t") && the value of the param && the URL to add $param to

864

865

$param =~ s/\=(.)*//; # just in case

866

my $rv = $url;

867

868

if ($param and $value and $url) {

869

$url = remove_param($param, $url);

870

if ($url =~ /\?/) {

871

my ($url, $params) = split(/\?/, $url);

872

if ($params) {

873

$rv = $url . "?$params&$param=$value";

874

} else {

875

$rv = $url . "?$param=$value";

876

}

877

} else {

878

$rv = $url . "?$param=$value";

879

}

880

}

881

882

return $rv; # modified url

883

#usage: my $r = add_param("t", "eyes", referrer());

884

}

885

886

########################

887

sub spaces($) {

888

889

# replaces each char in a scalar with a space

890

891

my ($s) = @_; # the string to convert

892

my $rv = $s =~ s/./ /g;

893

894

return $rv; # a scalar

895

#usage: my $s = spaces("llama's eat volleyballs");

896

}

897

898

########################

899

sub lc_littlewords($) {

900

901

# lowercases all small words

902

# ("such", "as", "an", "and", "the", "a")

903

904

my ($s) = @_; # the string to convert

905

my $rv = $s;

906

907

my @allowed = ();

908

push @allowed, "AD";

909

push @allowed, "AI";

910

push @allowed, "ARQ";

911

push @allowed, "AXL";

912

push @allowed, "BC";

913

push @allowed, "CD";

914

push @allowed, "ET";

915

push @allowed, "II";

916

push @allowed, "III";

917

push @allowed, "IV";

918

push @allowed, "VI";

919

push @allowed, "VII";

920

push @allowed, "VIII";

921

push @allowed, "IX";

922

push @allowed, "XI";

923

push @allowed, "XII";

924

push @allowed, "XIII";

925

push @allowed, "XIV";

926

push @allowed, "XV";

927

push @allowed, "LA";

928

push @allowed, "RV";

929

push @allowed, "USS";

930

931

my @littlewords = ();

932

push @littlewords, "a";

933

push @littlewords, "am";

934

push @littlewords, "an";

935

push @littlewords, "and";

936

push @littlewords, "are";

937

push @littlewords, "as";

938

push @littlewords, "at";

939

push @littlewords, "be";

940

push @littlewords, "but";

941

push @littlewords, "by";

942

push @littlewords, "can";

943

push @littlewords, "do";

944

push @littlewords, "for";

945

push @littlewords, "from";

946

push @littlewords, "in";

947

push @littlewords, "is";

948

push @littlewords, "if";

949

push @littlewords, "it";

950

push @littlewords, "it's";

951

push @littlewords, "my";

952

push @littlewords, "nor";

953

push @littlewords, "not";

954

push @littlewords, "of";

955

push @littlewords, "on";

956

push @littlewords, "or";

957

push @littlewords, "our";

958

push @littlewords, "so";

959

push @littlewords, "that";

960

push @littlewords, "the";

961

push @littlewords, "to";

962

push @littlewords, "what";

963

push @littlewords, "with";

964

push @littlewords, "yet";

965

push @littlewords, "you";

966

967

foreach my $word (@littlewords) {

968

$rv =~ s/( $word )/lc($1)/egi;

969

$rv =~ s/( $word)$/lc($1)/egi;

970

}

971

972

# and, uppercase certain 'words'

973

foreach my $okword (@allowed) {

974

$rv =~ s/( $okword )/uc($1)/egi;

975

$rv =~ s/( $okword)$/uc($1)/egi;

976

$rv =~ s/^($okword )/uc($1)/egi;

977

$rv =~ s/^($okword)$/uc($1)/egi;

978

$rv =~ s/( $okword,)/uc($1)/egi;

979

}

980

981

# next, sometimes, we see multiple spaces, convert them to single space

982

$rv =~ s/ {2,}/ /g;

983

984

# finally? now we have special cases. like "'Twas", and "vs"

985

my @specials = (); # one-offs

986

push @specials, "'Twas";

987

push @specials, "vs";

988

989

foreach my $special (@specials) {

990

if ($rv =~ /$special/i) {

991

if ($special =~ /^S\[/) {

992

$rv =~ s/($special)/uc $1/eig;

993

} else {

994

$rv =~ s/($special)/$special/ig;

995

}

996

}

997

}

998

999

# and now, remove extraneous spaces

1000

$rv =~ s/ ,/,/g; # space before comma

1001

$rv =~ s/ / /g; # double spaces

1002

$rv =~ s/^ +//; # leading spaces

1003

$rv =~ s/ +$//; # trailing spaces

1004

1005

return $rv; # a scalar

1006

#usage: my $s = lc_littlewords("The Quick Brown Fox Jumped Over The Lazy Dog");

1007

}

1008

1009

########################

1010

sub fixthe($) {

1011

1012

# reorganizes filename wording and casing

1013

# moves "The" from the start of a string, adds it

1014

# to the end of a line, preceded with a comma

1015

# this will also change "the", "is", "by" and

1016

# so-on anywhere else in the string to lowercase

1017

# this will also change casing, if required, of

1018

# Mr. and Mrs. and Dr. and so on, and retain the .

1019

1020

my ($s) = @_; # the string to convert (avoid including a path - just a filename, please)

1021

my $rv = "";

1022

my $preserver = "";

1023

if ($s =~ /^0 - /) {

1024

# this is a folder, not a file!

1025

$s =~ s/^0 - //;

1026

$preserver = "0 - ";

1027

}

1028

1029

# second, lowercase everything

1030

$s = lc $s;

1031

# then uppercase only the first letter of all words

1032

$s = join " ", map {ucfirst} split " ", $s;

1033

1034

# okay, let's try removing brackets now...cuz it ain't workin anywhere!

1035

$s =~ s/\(//g;

1036

$s =~ s/\)//g;

1037

1038

my $frontend = $s;

1039

my $middle = $s;

1040

my $backend = $s;

1041

my $ext = $s;

1042

$ext =~ s/.+\///;

1043

if ($ext eq $s) {

1044

$ext =~ s/.+\.//;

1045

if ($ext eq $s) { $ext = ""; }

1046

}

1047

1048

$backend =~ s/\.\Q$ext//;

1049

$backend =~ s/.* - //;

1050

$frontend =~ s/ - .*/ - /;

1051

1052

$middle =~ s/$frontend//;

1053

$middle =~ s/ - \Q$backend//;

1054

1055

if (not $middle) {

1056

$middle = $frontend;

1057

$frontend = "";

1058

$backend = "";

1059

}

1060

$middle =~ s/\.\Q$ext//;

1061

if ($middle eq $backend) { $middle = $frontend; $frontend = ""; }

1062

1063

$frontend =~ s/ - //;

1064

$middle =~ s/ - //;

1065

$backend =~ s/ - //;

1066

1067

if ($middle eq $backend) {

1068

$backend = "";

1069

} else {

1070

if ($frontend !~ /^[0-9][0-9]/ and $frontend) {

1071

$backend = $middle;

1072

$middle = $frontend;

1073

$frontend = "";

1074

$middle =~ s/ - //;

1075

}

1076

}

1077

1078

my $BUGIT = 0;

1079

if ($BUGIT) {

1080

my $temp = "$frontend \n";

1081

$temp .= "$middle \n";

1082

$temp .= "$backend \n";

1083

$temp .= "$ext \n";

1084

1085

return $temp; # a scalar, with debug info when debugger is on

1086

}

1087

1088

# now, lowercase the words that shouldn't be uppercased

1089

$frontend = lc_littlewords($frontend);

1090

$middle = lc_littlewords($middle);

1091

$backend = lc_littlewords($backend);

1092

1093

if ($middle =~ /^the /i) {

1094

$middle =~ s/^the //i;

1095

$middle .= ", The";

1096

}

1097

1098

$middle =~ s/, the$/, The/;

1099

1100

# now, ensure each part does not begin or end with a space!

1101

$frontend =~ s/^ +//; $frontend =~ s/ +$//;

1102

$middle =~ s/^ +//; $middle =~ s/ +$//;

1103

$backend =~ s/^ +//; $backend =~ s/ +$//;

1104

$ext =~ s/^ +//; $ext =~ s/ +$//;

1105

$ext = lc($ext);

1106

$backend =~ s/, the$/, The/i;

1107

1108

$rv = $frontend;

1109

if ($frontend) {

1110

$rv .= " - ";

1111

}

1112

$rv .= $middle;

1113

if ($middle and $backend) {

1114

$rv .= " - " . $backend;

1115

if ($ext) { $rv .= "." . $ext; }

1116

}

1117

1118

if (not $frontend and not $backend and $ext) {

1119

$rv .= "." . $ext;

1120

} else {

1121

if ($ext and $rv !~ /\.\Q$ext$/i and $rv !~ /\Q$s/i) {

1122

$rv .= $middle . $backend . "." . $ext;

1123

}

1124

}

1125

1126

# now, ensure mr, mrs, dr, etc are correctly formatted

1127

# there really ought to be a list for these to loop through

1128

$rv =~ s/^Mr /Mr. /ig;

1129

$rv =~ s/^Mrs /Mrs. /ig;

1130

$rv =~ s/^Ms /Ms. /ig;

1131

$rv =~ s/^Mt /Mt. /ig;

1132

$rv =~ s/^Dr /Dr. /ig;

1133

$rv =~ s/ Mr / Mr. /ig;

1134

$rv =~ s/ Mrs / Mrs. /ig;

1135

$rv =~ s/ Ms / Ms. /ig;

1136

$rv =~ s/ Mt / Mt. /ig;

1137

$rv =~ s/ Dr / Dr. /ig;

1138

$rv =~ s/ This\./ This\./ig;

1139

$rv =~ s/ That\./ That\./ig;

1140

$rv =~ s/ This$/ This/ig;

1141

$rv =~ s/ That$/ That/ig;

1142

1143

# good god, and now, words like "O'Toole" and "McMasters" and "MacDonald"?

1144

# this would be ideal if each case were in a list. but, that breaks somehow.

1145

# try adding one of the below to @specials, for instance, and you shall see

1146

# dots and brackets are taken literally, not sure why, either.

1147

$rv =~ s/ o'(.)/" O'" . uc $1/ieg;

1148

$rv =~ s/ mc(.)/"Mc" . uc $1/ieg;

1149

$rv =~ s/ mac(.)/"Mac" . uc $1/ieg;

1150

$rv =~ s/^o'(.)/"O'" . uc $1/ieg;

1151

$rv =~ s/^mc(.)/"Mc" . uc $1/ieg;

1152

$rv =~ s/^mac(.)/"Mac" . uc $1/ieg;

1153

1154

# same with these...

1155

$rv =~ s/(S[0-9][0-9])/uc $1/ieg;

1156

$rv =~ s/(E[0-9][0-9])/uc $1/ieg;

1157

1158

# okay, and now shit like " -," or "(.)-," gets converted to ","

1159

# and filenames ending with " -" or " - " or "- ";

1160

{

1161

my $fn = $rv;

1162

# remove the extension

1163

$fn =~ s/\..*$//i;

1164

my $ext = $rv;

1165

$ext =~ s/\Q$fn//;

1166

$ext =~ s/\.//g;

1167

# now search and destroy the intruders!

1168

$fn =~ s/ -,/,/g;

1169

$fn =~ s/(.)-,/$1,/g;

1170

1171

$fn =~ s/- $//g;

1172

$fn =~ s/ -$//g;

1173

$fn =~ s/ - $//g;

1174

1175

if ($ext) { $fn .= "." . $ext; }

1176

$rv = $fn;

1177

}

1178

1179

# next, search for "years", and insert a "- " before it

1180

if ($rv =~ /[0-9][0-9][0-9][0-9]/) {

1181

if ($rv !~ / - ([0-9][0-9][0-9][0-9])/) {

1182

$rv =~ s/([0-9][0-9][0-9][0-9])/- $1/;

1183

}

1184

}

1185

1186

# now, move year to end of line, if required

1187

$rv =~ s/ - ([0-9][0-9][0-9][0-9]), The/, The - $1/;

1188

1189

if ($preserver) { $rv = $preserver . $rv; }

1190

1191

return $rv; # a scalar

1192

#usage: my $s = fixthe("The Conjuring"); # returns "Conjuring, The"

1193

}

1194

1195

########################

1196

sub inArray($$;$$$) {

1197

1198

# is value (exact match) in a given array

1199

1200

my ($arrayRef, $value, $toEOL, $like, $exclude) = @_; # an array reference && a search term && match to end of line? && toggle eq/=~ && exclude value

1201

my $rv = 0;

1202

1203

if (ref $arrayRef eq "ARRAY") {

1204

my $i = 1;

1205

foreach my $v (@$arrayRef) {

1206

my $skipThis = 0;

1207

if ($exclude eq $v) { $skipThis = 1; }

1208

1209

if (not $skipThis) {

1210

if ($like) {

1211

if ($toEOL) {

1212

if ($v =~ /$value$/) {

1213

$rv = $i;

1214

last;

1215

}

1216

}

1217

else {

1218

if ($v =~ /$value/) {

1219

$rv = $i;

1220

last;

1221

}

1222

}

1223

1224

}

1225

else {

1226

if ($v eq $value) {

1227

$rv = $i;

1228

last;

1229

}

1230

1231

}

1232

}

1233

1234

$i++;

1235

}

1236

}

1237

1238

return $rv; # an array index, or -1 when not found

1239

#usage: my $s = inArray($arrayRef, "Farm");

1240

}

1241

1242

########################

1243

sub byte_count($);

1244

sub byte_count($) {

1245

1246

# to count the total bytes used in a data structure

1247

1248

my ($scalar) = @_; # a scalar (generally a reference)

1249

my $rv = 0;

1250

1251

if (ref $scalar eq "ARRAY") {

1252

foreach my $e (@$scalar) {

1253

$rv += byte_count($e);

1254

}

1255

} elsif (ref $scalar eq "HASH") {

1256

foreach my $key (keys %$scalar) {

1257

$rv += byte_count($scalar->{$key});

1258

}

1259

} elsif (ref $scalar eq "SCALAR") {

1260

$rv += length $$scalar;

1261

} else {

1262

$rv += length $scalar;

1263

}

1264

1265

return $rv; # a scalar

1266

#usage: my $count = byteCount($scalar);

1267

}

1268

1269

########################

1270

########################

1271

########################

1272

########################

1273

########################

1274

########################

1275

########################

1276

########################

1277

########################

1278

########################

1279

########################

1280

########################

1281

########################

1282

########################

1283

########################

1284

########################

1285

########################

1286

########################

1287

########################

1288

########################

1289

########################

1290

1291

########################

1292

sub _tests(;$) {

1293

1294

# to test all Pm::Bc_dir functions

1295

1296

my ($extended) = @_; # show extended data (optional)

1297

my $rv = 0;

1298

my $test = 0;

1299

my $test2 = 0;

1300

my $test3 = 0;

1301

my $test4 = 0;

1302

my @test = ();

1303

my @test1 = ();

1304

my @test2 = ();

1305

my @test3 = ();

1306

my %test = {};

1307

1308

if ($Bc_sql::DB) {

1309

$test = "octopus";

1310

$rv = Html::display_debug_one("a_or_an(\"$test\")", a_or_an($test));

1311

$test = 1;

1312

$rv .= Html::display_debug_one("add_numeric_suffix($test)", add_numeric_suffix($test));

1313

$test = "01";

1314

$rv .= Html::display_debug_one("add_zeros($test)", add_zeros($test));

1315

$test = -1234567890;

1316