File Coverage

blib/lib/DB/Ent.pm

Criterion	Covered	Total	%
statement	61	299	20.4
branch	3	152	1.9
condition	10	95	10.5
subroutine	15	56	26.7
pod	20	27	74.0
total	109	629	17.3

line

stmt

bran

cond

sub

pod

time

code

# DB::Ent - A Database Entity Layer

# This program is free software; you can redistribute it and/or modify

# it under the terms of the GNU General Public License as published by

# the Free Software Foundation; either version 2 of the License, or

# (at your option) any later version.

# This program is distributed in the hope that it will be useful,

# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License

# along with this program; if not, write to the Free Software

# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

=head1 NAME

DB::Ent - Database Entity Layer

=head1 SYNOPSIS

use DB::Ent;

$ef = DB::Ent->new(); # entity factory

$au = $ef->mk(artist => "Peter Gabriel"); # create an artist

$cd = $au->mksub(CD => "Passion"); # create subordinate entity

$cd->attr(id => "0x0440F020") || die; # set attributes

$cv = $dbe->mk(cover => "http://..."); # create a cover

$cd->rel($cv); # link to CD

$cd->rm(); # remove the CD

=head1 DESCRIPTION

This module presents an interface to an entity-centric database schema, providing all necessary methods to create, discover and manipulate entities and associated data.

The schema consists of 4 basic element storage types: 1) entities, 2) attributes, 3) relationships, and 4) extended attributes.

The terms C and C are used here in accordance to the common definition used in relational database theory.

A differentiating factor between an entity and an attribute is that attributes serve no other purpose but to qualify an entity and cannot exist on their own. Entities may exist without qualifiers, requiring only a name.

Relationships of various kinds may be established between any two entities and these may be codified, enumerated or both.

Extended attributes comprise special datatypes and are typically used to store large format data.

=cut

# --- prologue ----------------------------------------------------------------

package DB::Ent;

26464

use 5.006;

use strict;

use warnings;

use Exporter;

use vars qw/@ISA/;

5138

our $VERSION = substr q$Revision: 1.63 $, 10;

sub OK { 1; }

### TODO ###

# new(): allow empty values for attributes

# --- exported module interface -----------------------------------------------

=head1 SYNTAX

Methods are listed by declaring their signatures, the general format of which consists of a return value followed by an equal sign and the method name, followed by a list of parameters, e.g.

IreturnE = method-name ErequiredE [optional = default] {alternate1 | alternate2}>

=head2 Parameters

Required parameters are named within angles whilst optional parameters within brackets; alternative parameters use braces separated by pipes. Whenever optional parameters are specified, the default value may be represented by following the parameter name with an equal sign and the default value. When listing alternative parameters the syntax may nest brackets, e.g. the line below names that EITHER two required parameters may be passed OR a hash or hash reference.

I<{Eval-1E Eval-2E | hash[-ref]}>

Please note that failing to pass required arguments in a method call results in program death.

=head2 Return values

In general, methods return objects unless an error occurs in which case I is returned. Certain methods specify their return value as I which indicates a success flag (set to I on failure). Upon encountering an error, the caller should consult the {err} and {errstr} fields in the object which contain a numeric error code and its corresponding description string.

Return values are typically context-sensitive and may also be sensitive to the argument signature. When different return values may be expected, these appear separated with pipes. When the return value is an IerrE>, if the context is scalar, only error code is returned.

=head2 Signature templates

Whenever the syntax for a method is indicated with a double colon, it specifies that the signature for the current method follows that of a template method which is indicated following the double colon (e.g. I). Parameters to the method in question are placed after the template's last required parameter and before its first optional parameter.

=cut

# --- entity factory methods --------------------------------------------------

=head1 METHODS

100

101

The module presents an object-oriented interface divided into two major functional groups: entity-factory methods, and entity-management methods.

102

103

Entity factory methods concern the binding of perl objects to datastore items. This includes insertion, discovery and retrieval methods as well as entity-factory configuration methods. This category includes the following:

104

105

=head2 = new [hash[-ref]]

106

107

Before entities can be created and managed, an entity factory must be instantiated. This method returns such an object and receives two kinds of parameters: connection parameters, and configuration parameters. If any error is encountered the method returns I for the object, followed by an error list.

108

109

Parameters are all passed as a hash or hash reference whose keys are described below:

110

111

112

113

To establish a connection to a datastore, the caller must pass credentials. These may be passed either in URL syntax and/or as separate keys. Any information passed separately overrides the appropriate value in the URL. If no connection information is passed, the variable I in the main namespace is assumed to contain a URL with the information. If this variable is empty, the environment variable of the same name is used. Any credential pieces not passed assume defaults.

114

115

=over

116

117

=item DBED

118

119

Indicates the low-level driver to use. At present this value defaults to and can only be set to C. As other low level drivers are written, their names may be passed here.

120

121

=item URL

122

123

Specifies a connection URL of the form: I where the items indicated in brackets are optional and which may be passed separately as described below.

124

125

=item proto

126

127

This key specifies the drivers to use for connecting to a datastore. The value will be passed through to the I and if not supplied, the DBED will select an appropriate default e.g. C.

128

129

=item host

130

131

This indicates the name or IP address of the server hosting the datastore. If not provided, the low level driver will choose a default.

132

133

=item user

134

135

Specifies the account to use for logging into the datastore. If not provided the low-level driver will choose a default.

136

137

=item password

138

139

Necessary when security measures have been placed on the account in use. Passwords are provided in plain-text. If not provided, default is left to the low-level driver.

140

141

=item database

142

143

This key specifies the namespace within the server to use. If not specified, a default home will be used. Please note however that not all database systems either have a namespace concept, nor a default value for it.

144

145

=back

146

147

148

149

The following keys define various behaviours for the entity factory. The values are stored as keys in the object itself and may be manipulated directly.

150

151

=over

152

153

=item mkuid

154

155

Specifies a code reference to be used in generating unique ids e.g. I<\MyModule::nextid>. If no value is specified, unique strings are computed based on the md5 value of the canonicalised name.

156

157

=item dups

158

159

The duplicates flag indicates the action to take when db insert fails because an entity already exists. The value may be set to any of the following constants B, B, B (see section B at the end of this document).

160

161

=item upsert

162

163

This key allows the user to automatically overwrite existing entity attributes. For more information please see the the B method.

164

165

=item debug

166

167

Setting this key allows for debugging output to be produced by the module. A 1 is the minimum required with increased verbosity resulting from larger values. By default no debugging output is generated.

168

169

=item trace

170

171

Setting this key to a filename will cause all commands issued to the datastore to be recorded in the file.

172

173

=back

174

175

176

177

The following methods may be overridden by the caller as desired:

178

179

=over

180

181

=item dbcmd

182

183

This method is called with the full command about to be sent to the datastore. By default this method does nothing;

184

185

=item dberr

186

187

This key allows the caller to specify an error handler to use when low-level driver problems arise. The constants B (current default) and B may also be used to request that the default error handler die or merely warn upon errors;

188

189

=back

190

191

=cut

192

193

sub new {

194

495

my $proto = shift;

195

my $class = ref($proto) || $proto;

196

my $self = bless { DBED => "DBI", &args }, $class;

197

198

$self->{debug} ||= 0;

199

200

my $DBED = "DB::Ent::" . $self->{DBED};

201

eval qq/require $DBED/ unless $self->{DBED} eq "DBI";

202

@ISA = ($DBED);

203

204

$self->u2h();

205

$self->SUPER::new(

206

debug => $self->{debug} - 1,

207

trace => $self->{trace},

208

);

209

210

my @err = ($self->{err}, $self->{errstr});

211

$self = undef if $err[0];

212

wantarray() ? ($self, @err) : $self;

213

}

214

215

=head2 = mk

[attr-hashref]

216

217

Creates an entity with the given name and type and populates it with the attributes given in the optional hash reference. If the object already exists in the datastore no insertion is made and any attributes provided are discarded, unless the I flag is set in the entity factory, in which case all attributes specified are overwritten with the values supplied.

218

219

All entities have a unique id, normally calculated upon creation by the B method (see Configuration Parameters for the B method). This default id is generated from a combination of the name and type of entity and may be overridden by specifying the I key in the attribute hash. Additionally, to generate the uid using the current uid generator but with an alternative value, the key I may be passed.

220

221

=cut

222

223

sub mk {

224

my ($self, $type, $nm, $d) = @_;

225

226

die qq/mk(): No name passed!/ unless $nm;

227

die qq/mk(): No type passed!/ unless $type;

228

229

my ($ent, $id);

230

$id->{uid} = $d->{uid} || $self->uid($d->{uidstr} || "$type:$nm");

231

delete $d->{uidstr};

232

233

unless ($ent = $self->ent($id)) {

234

$ent = {nm => $nm, type => $type, uid => $id->{uid}};

235

$ent->{id} = $self->ins(ent => $ent) || return;

236

$ent->{$_} = $self->{$_} for qw/dbh debug/;

237

bless $ent, ref($self);

238

}

239

240

return $ent if $ent->attr($d) == 0;

241

}

242

243

=head2 = ent [opts-hash[-ref]]

244

245

This method retrieves entities from the datastore.

246

247

Entities are returned according to selection criteria which are specified in a hash consisting of the attribute values being sought. Values in the selection hash may contain list references when multiple matches are desired. Additionally, hash values may contain the I<%> wildcard to indicate partial matches. If no selection criteria are specified, the method will assume an I is being sought and takes the value of I<$_>.

248

249

A hash of options intended to modify the return set may also be passed containing keys as outlined below:

250

251

=over

252

253

=item sort

254

255

Specifies the attribute(s) to sort results by. A list reference may be passed when multiple values are desired; defaults to C.

256

257

=back

258

259

The return value consists of blessed objects, the number of which depends on the selection criteria. When a single object is found it is returned as a scalar, unless the calling context requests a list.

260

261

B The entities returned by this method contain only the most minimal of information i.e. that contained in the B table. No attribute, relationship or other information is retrieved but these values may be got by calling specific methods for each. For a catalogue of such methods please refer to the B section below.

262

263

=cut

264

265

sub ent {

266

my $self = shift;

267

my $sel = shift;

268

$sel = { $sel =~ /^\d+$/ ? "id" : "nm" => $sel }

269

unless ref $sel;

270

271

my $opts = &args;

272

$opts->{sort} ||= "nm";

273

274

my (@ent, @ret);

275

@ent = $self->sel(ent => $sel, sort => $opts->{sort});

276

push @ret, bless $_, $self for @ent;

277

278

@ret == 1 && !wantarray() ? $ret[0] : @ret;

279

}

280

281

=head2 = cs

282

283

This method returns a url containing the connection information in use for the given datastore object. For information on the format of this string, please refer to the I argument to the I method.

284

285

=cut

286

287

sub cs {

288

my $self = shift;

289

$self->h2u();

290

}

291

292

# --- entity management methods -----------------------------------------------

293

294

=head1 METHODS - Entity Management

295

296

The methods listed below provide mechanisms for managing entity objects, their attributes and relationships. These methods can only be called on the objects generated by calls to entity-factory methods.

297

298

=head2 = rm [RELSONLY]

299

300

Removes an entity and all relationships to other entities. The method works recursively, destroying all dependencies, otherwise requested. For more information please refer to the documentation for the B method.

301

302

=cut

303

304

sub rm {

305

my ($self, $rels) = @_;

306

307

$self->rmattr() || return;

308

$self->rmrel(relsonly => $rels) || return;

309

$self->del(ent => {id => $self->id}) || return;

310

311

OK;

312

}

313

314

=head2 mksub :: mk

315

316

Creates a sub-ordinate entity. The method must be called from an object generated by an entity factory and assumes such serves as the parent.

317

318

=cut

319

320

sub mksub {

321

my ($self, $type, $nm, $d) = @_;

322

323

my $ent = $self->mk($type => $nm, $d)

324

|| return;

325

$ent->rel($self)

326

|| return;

327

328

$ent;

329

}

330

331

# --- attribute methods -------------------------------------------------------

332

333

=head2 | = attr [ [value = $_] | attr-hashref]

334

335

Sets attributes for an entity.

336

337

Two parameter signatures are allowed; in the first form the method sets a single attribute; the second form allows for multiple attributes to be set. The return value in this case consists of an I value.

338

339

Attributes are created whenever they do not exist in the datastore but when already present, their values are respected, unless the I flag in the entity factory is set.

340

341

The current value of an attribute may be updated via a calculation by passing a code reference as a I. The code-ref will be called with the value of I<$_> set to the current attribute's value and will be responsible for returning the new value, e.g. to increment a value the following may be used:

342

343

I<$self-Eattr(count =E sub { $_++ });>

344

345

=cut

346

347

sub attr {

348

my ($self, $attr, $val) = @_;

349

350

$val = $_ unless ref($attr) || defined($val);

351

my %attr = ref($attr) ? %$attr : ($attr, $val);

352

353

# bail if no attrs to process

354

355

return !OK unless %attr;

356

357

# intrinsic attributes don't get stored in the C table

358

359

for ($self->tabcols("ent")) {

360

next if /^id$/i;

361

delete $attr{$_};

362

}

363

364

# grab attributes in case me virgin

365

366

$self->attrs() unless $self->{__cf}{attrs};

367

368

# insert attributes

369

370

for (keys %attr) {

371

my $v = $attr{$_} || next;

372

$self->{$_} ||= "";

373

next if $self->{$_} eq $v;

374

375

my ($nm, $dt) = nmdt(); # attribute names may include datatype

376

next unless $nm; # attributes should have names

377

$dt ||= strdt($v); # guess datatype if not specified

378

379

my $fn = $self->{$_} ? "upd" : "ins";

380

my $ret = $self->$fn(

381

attr => { nm => $nm, $dt => $v },

382

{ id => $self->id }

383

);

384

385

# inserts into C do not auto-generate

386

# an id so the return value of ins() is not

387

# meaninful and sqlerr() must be checked

388

389

$ret = $self->dberr() if $fn eq "ins";

390

return !OK unless $ret;

391

392

$self->{$nm} = $v;

393

}

394

395

OK;

396

}

397

398

=head2 = attrs [attr-listref] [DTT]

399

400

Retrieves the attributes of an identity. Specific attributes may be requested by passing their names in a list reference. If the constant B is passed, datatype information will be embedded in the keys of the return hash.

401

402

The attributes retrieved (and returned) are also embedded internally into the object.

403

404

=cut

405

406

sub attrs {

407

my ($self, $nm, $dtt) = @_;

408

409

my %attr;

410

for ($self->sel(attr => {id => $self->id, nm => $nm})) {

411

my $nm = $_->{nm};

412

for my $dt (qw/s i f d/) {

413

my $v = $_->{$dt} || next;

414

$attr{$dtt ? "$dt:$nm" : $nm} = $v;

415

last;

416

}

417

}

418

419

$self->{__cf}{attrs} = 1; # already queried

420

%$self = (%$self, %attr);

421

$nm ? $attr{$nm} : wantarray() ? %attr : \%attr;

422

}

423

424

=head2 = rmattr [attr-list]

425

426

Removes an entity's attributes. If a list of attribute names is provided, only those attributes are removed.

427

428

=cut

429

430

sub rmattr {

431

my $self = shift;

432

my $crit = { id => $self->id() };

433

$crit->{nm} = \@_ if @_;

434

$self->del(attr => $crit);

435

}

436

437

# --- relationship methods ----------------------------------------------------

438

439

=head2 = rel [options-hashref]

440

441

Creates a relationship between the current entity and a list of given entities. Relationshps are always enumerated but may also be codified, as indicated in the options hash optionally passed. Valid keys for this hash are as follows:

442

443

=over

444

445

=item type

446

447

Specifies the type of relationship. If no type is specified, the relationship is not considered to be codified.

448

449

=item nn

450

451

Passing a value with this key cements the relationship number between two entities. Generally there is no good reason to want this, and as attempting to establish a relationship between to entities with the same numeric value (within a given relationship-type (code)) will cause an error, abstention from use of this key is recommended. If not specified, its value is calculated as the next number available.

452

453

=item unique

454

455

If this key is set to true, the system will enforces a single relationship between the two entities (regardless of relationship type). By default this value is false.

456

457

=item parent

458

459

Most commonly the caller will intend to create child relationships between the current entity and the passed list of subordinate entities. At times however, it may be necessary to reverse the sense of this assignment, making each of the entities in the list, the parent of the current entity. Setting this flag to true allows for that to happen.

460

461

=back

462

463

=cut

464

465

sub rel {

466

my ($self, $rel, $opts) = @_;

467

468

my @rel = ref($rel) eq "ARRAY" ? @$rel : ($rel);

469

for (@rel) {

470

my $i = $opts->{nn} || 1 + $self->max(rel => "i", {

471

id => $self->id, pid => $_->id, type => $opts->{type}

472

});

473

474

next if $opts->{unique} && !$opts->{nn} && $i > 1;

475

476

my ($id, $pid) = $opts->{parent} ? qw/pid id/ : qw/id pid/;

477

$self->ins(rel => {

478

$id => $self->id, $pid => $_->id, type => $opts->{type}, i => $i

479

});

480

return if $self->{err};

481

}

482

483

OK;

484

}

485

486

487

=head2 = rels [opts-hash[-ref]]

488

489

Returns a list of entities related to the current entity. Please note that these values get cached inside the object as either I<_parents_> or I<_children_>.

490

491

The options hash specifies behaviour as follows:

492

493

=over

494

495

=item cd

496

497

The caller may limit the entities returned by relationship code. The value passed may be either a scalar or a list reference.

498

499

=item parent

500

501

If this flag is set, instead of returning an entity's children, the parents are returned.

502

503

=back

504

505

=cut

506

507

sub rels {

508

my $self = shift;

509

my $opts = &args;

510

511

my @ret; my $id = $opts->{parent} ? "id" : "pid";

512

for ($self->sel(rel => {$id => $self->id, cd => $opts->{cd}})) {

513

push @ret, $self->ent($_->{id});

514

}

515

516

$self->{$opts->{parent} ? "_parents_" : "_children_"} = \@ret;

517

wantarray ? @ret : \@ret;

518

}

519

520

=head2 = rmrel [ents => listref, relsonly => 1]

521

522

Removes an entity's relationships with the given list of entities by removing these from the datastore. Please note that this process works recursively, removing children's children to any level, thus effectively pruning the relationship tree connected at the current entity. If the list passed is empty, all children are removed.

523

524

If the flag I is set, the method only severs the entity's relationships with other entities without destroying these.

525

526

=cut

527

528

sub rmrel {

529

my ($self, %args) = @_;

530

531

unless ($args{relsonly}) {

532

my @rels = $args{ents} || $self->rels();

533

$_->rm() || last for @rels;

534

}

535

536

$self->del(rel => {id => $self->id}) || return;

537

$self->del(rel => {pid => $self->id}) || return;

538

539

OK;

540

}

541

542

=head2 = args [hash, hash-ref, ...]

543

544

This function conveniently parses arguments passed to a method. It should be called in non OO style without arguments and returns a hash or hash reference (depending on context) with the values.

545

546

I<- exempli gratia ->

547

548

sub tst {

549

my $args = &DB::Ent::args;

550

print $args->{key};

551

}

552

553

=cut

554

555

sub args {

556

my @ret = @_;

557

for my $i (0 .. $#ret) {

558

splice @ret, $i, 1, %{ $ret[$i] } if ref $ret[$i] eq "HASH";

559

}

560

561

wantarray() ? @ret : { @ret };

562

}

563

564

# --- internal methods and functions ------------------------------------------

565

566

sub id {

567

my $self = shift;

568

$self->{id};

569

}

570

571

# converts a connection url to a hash

572

573

sub u2h {

574

my $self = shift;

575

local $_ = $self->{URL} || $::DBE || $ENV{DBE} || "";

576

577

my @dbk = qw/proto usr pwd srv dbn/;

578

my %url; @url{@dbk} = m|^(\w+)://(\w+):?(\w*)@?(\w+)/?(\w+)$|;

579

$self->{$_} ||= $url{$_} for @dbk;

580

}

581

582

# converts a connection hash to a url

583

584

sub h2u {

585

my $self = shift;

586

local $_ = sprintf("%s://%s:%s@%s/%s",

587

$self->{proto},

588

$self->{usr}, $self->{pwd},

589

$self->{srv}, $self->{dbn}

590

);

591

s/:@/@/;

592

$_;

593

}

594

595

# generate unique id strings.

596

# if a function has been defined for this purpose no string may

597

# be necessary but if the uid is being generated by us, we need a

598

# string (typically the name)

599

600

sub uid {

601

my $self = shift;

602

my $nm = shift;

603

604

return $self->{mkuid}($nm) if $self->{mkuid};

605

606

return unless $nm;

607

require String::Canonical;

608

import String::Canonical qw/cstr/;

609

require Digest::MD5;

610

import Digest::MD5 qw/md5_hex/;

611

612

md5_hex(cstr($nm));

613

}

614

615

616

# Syntax:

617

# = strdt [string = $_]

618

# Synopsis:

619

# Returns the heuristic datatype of a string

620

621

622

sub strdt {

623

local $_ = @_ > 0 ? shift : $_;

624

return "i" if /^-?\d+$/;

625

return "f" if /^-?\d+\.?\d*$/;

626

return "d" if m|^\d{1,2}/\d{1,2}/(\d\d){1,2}|;

627

return "s";

628

}

629

630

631

# Syntax:

632

# = nmdt [attr-nm = $_]

633

# Synopsis:

634

# Splits a compound attribute name into its value

635

# and it's datatype

636

637

638

sub nmdt {

639

local $_ = shift || $_;

640

my ($dt, $nm) = /^(?:(.):)?(.*)$/; # datatype may be embedded

641

return ($nm, $dt || "");

642

}

643

644

=head1 CONSTANTS

645

646

A number of constants are used by the various methods; these are typically access directly from the package e.g. B<$DB::Ent::DTT>. A description of each follows:

647

648

=over

649

650

=item DUPSQUIET

651

652

specifies that entity creation failures owning to duplicate keys should be silently ignored.

653

654

=item DUPSWARN

655

656

specifies duplicate key violations should issue warnings.

657

658

=item DUPSDIE

659

660

specifies duplicate key violations should cause the process to die.

661

662

=item ERRWARN

663

664

specifies that only warnings should be issued when encountering errors.

665

666

=item ERRDIE

667

668

specifies that the process should die when errors are found.

669

670

=item RELSONLY

671

672

#FIXME

673

674

=item DTT

675

676

#FIXME

677

678

=back

679

680

=cut

681

682

sub DUPSQUIET { 1; }

683

sub DUPSWARN { 2; }

684

sub DUPSDIE { 3; }

685

sub ERRWARN { 0; }

686

sub ERRDIE { 1; }

687

sub RELSONLY { 1; }

688

sub DTT { 1; }

689

690

=head1 DRIVERS

691

692

Drivers are modules that provide low-level primitives to access specific datastores. Please note that the I/I nomenclature may not map directly to a I/I, I/I, I/I, I/I or other metaphor supported by the underlying datastore.

693

694

At present only a DBI driver exists but a published API (see man page for DB::Ent::DBI) exists to allow developers to write other drivers.

695

696

=head1 AUTHOR

697

698

Erick Calder

699

700

=head1 SUPPORT

701

702

For help and thank you notes, e-mail the author directly. To report a bug, submit a patch or add to our wishlist please visit the CPAN bug manager at: F

703

704

=head1 AVAILABILITY

705

706

The latest version of the tarball, RPM and SRPM may always be found at: F Additionally the module is available from CPAN.

707

708

=head1 LICENCE AND COPYRIGHT

709

710

This utility is free and distributed under GPL, the Gnu Public License. A copy of this license was included in a file called LICENSE. If for some reason, this file was not included, please see F to obtain a copy of this license.

711

712

=head1 SEE ALSO

713

714

715

716

$Revision: 1.63 $, $Date: 2003/06/24 03:58:11 $

717

718

=cut

719

720

# --- DBI Driver --------------------------------------------------------------

721

722

=head1 NAME

723

724

DB::Ent::DBI - DBI Driver for DB::Ent

725

726

=head1 SYNOPSIS

727

728

use DB::Ent::DBI;

729

$dbx = DB::Ent::DBI->new();

730

$dbx->ins();

731

$dbx->del();

732

$dbx->upd();

733

734

=head1 DESCRIPTION

735

736

This module provides a DBI-based driver for the DB::Ent schema abstraction layer and serves as a guideline for other driver development efforts by documenting the API.

737

738

Please note that for this driver the choice of nomenclature consists of I. Also, some methods return IerrE>; this is a list consisting of a numeric error code, followed by its human-legible corresponding string.

739
740						=cut
741
742						# --- prologue ----------------------------------------------------------------
743
744						package DB::Ent::DBI;
745
746	1			1	30	use 5.006;
	1				4
	1				42
747	1			1	6	use strict;
	1				2
	1				36
748	1			1	62	use warnings;
	1				3
	1				39
749	1			1	2906	use DBI;
	1				23136
	1				74
750	1			1	12	use vars qw/$VERSION %tabs @QDTT/;
	1				2
	1				2565
751
752						$VERSION = substr q$Revision: 1.63 $, 10;
753
754						@QDTT = qw/char text date/; # datatypes that need quoting
755
756						%tabs = (
757						ent => [
758						"id int unsigned not null auto_increment primary key",
759						"nm varchar(255)", # name
760						"type varchar(30)", # namespace-qualified class
761						"uid char(32) UNIQUE", # universal id
762						],
763						attr => [
764						"id int unsigned not null", # FK: ent (no DRI)
765						"nm varchar(32)", # name
766						"i int", # various value
767						"f float", # data types
768						"s varchar(255)",
769						"d datetime",
770						"UNIQUE (id, nm)",
771						],
772						rel => [
773						"id int unsigned not null", # FK: ent
774						"pid int unsigned not null", # parent id
775						"type char(4)", # relationships can be codified
776						"i int", # and/or enumerated
777						"UNIQUE (id, pid, type, i)",
778						],
779						xattr => [
780						"id int unsigned not null", # FK: ent
781						"type char(4)",
782						"s text", # ascii blob
783						"FULLTEXT (s)",
784						],
785						);
786
787						while (my ($tab, $cols) = each %tabs) {
788						$tabs{$tab} = {};
789						for (@$cols) {
790						my ($nm, $def) = /^(\w+)\s(.)/i;
791						if ($nm eq uc($nm)) {
792						push @{$tabs{$tab}{mods}}, "$nm $def";
793						next;
794						}
795						$tabs{$tab}{cols}{$nm}{def} = $def;
796						$tabs{$tab}{cols}{$nm}{quote} \|\|= $def =~ /$_/i for @QDTT;
797						}
798						}
799
800	0			0	0	sub OK { 1; }
801
802						# --- exported module interface -----------------------------------------------
803
804						=head2 = new [pass-through]
805
806						Used to generate a datastore connection object. Any optional arguments passed may be used to create and configure the connection. The method returns a list containing a blessed object, a numeric error code, and a human legible error string.
807
808						If the object is set to I the caller should check the error values, else the returned object may be used to access the methods listed below:
809
810						=cut
811
812						sub new {
813	1			1	3	my $self = shift;
814	1	0			4	return unless $self->dbc(&DB::Ent::args);
815
816	0		0		0	$self->{dups} \|\|= $DB::Ent::DUPSWARN;
817	0				0	$self->{dbh}->{PrintError} = 0; # we'll display errors
818	0	0			0	$self->{dbh}->trace(2, $self->{trace})
819						if $self->{trace};
820
821	0				0	OK;
822						}
823
824						sub dbc {
825	1			1	3	my $self = shift;
826	1				11	%$self = (%$self, @_);
827
828	1		50		9	$self->{proto} \|\|= "mysql";
829	1		50		6	$self->{srv} \|\|= "localhost";
830	1		33		1243	$self->{usr} \|\|= (getpwuid($>))[0];
831	1		50		10	$self->{pwd} \|\|= "";
832	1		50		3	$self->{dbn} \|\|= "";
833
834	1				3	my $dsn = join ":", "DBI", @{$self}{qw/proto dbn srv/};
	1				6
835	1				13	$self->{dbh} = DBI->connect($dsn, $self->{usr}, $self->{pwd});
836	0					@{$self}{qw/err errstr/} = ($?, $!);
	0
837
838	0					!$?;
839						}
840
841						=head2 = init
842
843						Used to create an entity schema this method must be called with extreme care as it will first destroy an existing schema, including all data. Before this method may be called, a connection to the datastore must be established.
844
845						Typically it is not necessary for users to call this method directly since the B method will call it if it detects that the datastore has not been initialised.
846
847						The storage element types (in the nomenclature of this driver these are database tables) created are named: I, I, I, and I. The B parameter to the various methods offered by this module must receive one of these values.
848
849						This method takes no arguments and returns a success flag.
850
851						=cut
852
853						sub init {
854	0			0		my $self = shift;
855	0					my %args = @_;
856	0					for (keys %tabs) {
857	0	0				$self->x("DROP TABLE IF EXISTS $_") if $args{DROP};
858	0	0				$self->tabmk() \|\| return;
859						}
860	0					OK;
861						}
862
863						=head2 = ins [filt-hashref]
864
865						Creates a new entry of the type indicated by the first argument passed (see docs for the I method above for a review of valid names). Attributes must be passed in a hash reference and must match those allowed by the element type.
866
867						The return value consists of the id of the new entry; in case of failure error information is returned.
868
869						B For signature compatibility with I, this method accepts a filter hash reference whose keys are added to the I. This makes for easy upserts!
870
871						=cut
872
873						# needs to support upserts and coderefs for values
874
875						sub ins {
876	0			0		my ($self, $nm, $args, $filt) = @_;
877	0					my (@cols, @vals);
878	0	0				$args = {%$args, %$filt} if ref($filt) eq "HASH";
879	0					for (keys %$args) {
880	0					push @cols, $_;
881	0	0				push @vals, $tabs{$nm}{cols}{$_}{quote}
882						? $self->q($args->{$_})
883						: $args->{$_}
884						;
885						}
886
887						$self->x(
888	0					sprintf("INSERT INTO $nm (%s) VALUES (%s)",
889						join(",", @cols),
890						join(",", @vals),
891						)
892						);
893						}
894
895						=head2 = upd [filt-hashref]
896
897						This method updates an entry of the type specified by the I parameter (see docs for the I method above for a review of valid names). The data updated is provided as a hash reference of attribute name/value pairs. Additionally a filter may be provided (also as a hash reference of attribute name/value pairs) which limits the update operation to only those entries specified (in table parlance, this represents a row selector i.e. an sql where clause).
898
899						The return value indicates the number of rows affected.
900
901						=cut
902
903						sub upd {
904	0			0		my ($self, $nm, $attr, $filt) = @_;
905
906	0					my $attrs;
907						$attrs .= "$_ = " . $self->q($attr->{$_}) . ", "
908	0					for keys %$attr;
909	0					$attrs =~ s/,\s+$//;
910	0					my $WHERE = $self->where($nm, $filt);
911
912	0					$self->x("UPDATE $nm SET $attrs $WHERE");
913						}
914
915						=head2 = del
916
917						Deletes any entity that matches the given list of attributes' values. Instead of not passing any attributes in the hash reference in order to delete all items in a table, pass the key I set to 1 - this is to prevent costly mistakes.
918
919						=cut
920
921						sub del {
922	0			0		my $self = shift;
923	0					my ($nm, $cols) = @_;
924
925	0	0	0			my $WHERE = $cols->{ALL} ? "" : $self->where($nm, $cols) \|\| return;
926	0					$self->x("DELETE FROM $nm $WHERE");
927						}
928
929						=head2 = sel
930
931						Returns a list of hash references containing entities that match the selection criteria. The values in the hash to this method may contain list references and wildcards are allowed within scalars for incomplete matching.
932
933						=cut
934
935						sub sel {
936	0			0		my ($self, $nm, $cols, %opts) = @_;
937	0		0			$opts{sort} \|\|= 1;
938
939	0					my $WHERE = $self->where($nm, $cols);
940	0					$self->x("SELECT * FROM $nm $WHERE ORDER BY $opts{sort}");
941						}
942
943						sub max {
944	0			0		my $self = shift;
945	0					my $nm = shift;
946	0					my $col = shift;
947	0					my $WHERE = $self->where($nm, &DB::Ent::args);
948	0					my @ret = $self->x("SELECT max($col) max FROM $nm $WHERE");
949	0	0				$ret[0]->{max} \|\| 0;
950						}
951
952						=head2 = def
953
954						Returns a list of attributes associated with a particular entity type.
955
956						=cut
957
958						# --- internal utility methods ------------------------------------------------
959
960						sub tabcols {
961	0			0		my $self = shift;
962	0		0			my $nm = shift \|\| $_;
963	0					keys %{$tabs{$nm}{cols}};
	0
964						}
965
966						sub tabmk {
967	0			0		my $self = shift;
968	0		0			my $nm = shift \|\| $_;
969
970	0					my @cols;
971	0					push @cols, "$_ $tabs{$nm}{cols}{$_}{def}"
972	0					for keys %{$tabs{$nm}{cols}};
973	0					push @cols, $_
974	0					for @{$tabs{$nm}{mods}};
975	0					$self->x(
976						sprintf("CREATE TABLE IF NOT EXISTS $nm (%s)", join(",", @cols))
977						);
978						}
979
980						# constructs predicates for a where clause
981
982						sub where {
983	0			0		my $self = shift;
984	0					my $tab = shift;
985
986	0					my @ret; my %cols = &DB::Ent::args;
	0
987	0					while (my ($nm, $v) = each %cols) {
988	0	0				next unless defined $v;
989
990	0					my $q = $tabs{$tab}{cols}{$nm}{quote};
991	0	0				if (ref $v eq "ARRAY") {
992	0	0				$v = $q ? $self->qin($v) : $self->in($v);
993	0					push @ret, "$nm IN ($v)";
994	0					next;
995						}
996	0	0				if ($v =~ /%/) {
997	0					push @ret, "$nm LIKE " . $self->q($v);
998	0					next;
999						}
1000	0	0				push @ret, "$nm = " . ($q ? $self->q($v) : $v);
1001						}
1002
1003	0	0				return "WHERE " . join " AND ", @ret if @ret;
1004						}
1005
1006						# safe-quotes a list[-ref] of strings
1007
1008						sub q {
1009	0			0		my $self = shift;
1010	0					my @v = &DB::Ent::args;
1011	0					$_ = $self->{dbh}->quote($_) for @v;
1012	0	0	0			warn "q(): multiple args but scalar context!"
1013						if @v > 1 && !wantarray();
1014	0	0				wantarray() ? @v : $v[0];
1015						}
1016
1017						sub in {
1018	0			0		my $self = shift;
1019	0					join ", ", &DB::Ent::args;
1020						}
1021
1022						# returns a string ready for use with an IN statement
1023
1024						sub qin {
1025	0			0		my $self = shift;
1026	0					join ", ", $self->q(@_);
1027						}
1028
1029						# Syntax:
1030						# = x
1031						# = x
1032						# = x
1033						# = x
1034
1035						sub x {
1036	0			0		my $self = shift;
1037	0		0			$self->{cmd} = shift \|\| $_ \|\| return warn qq/x(): No command!/;
1038	0	0				$self->dbcmd() if $self->{debug} > 0;
1039
1040						# prepare and execute
1041
1042	0		0			my $sth = $self->{dbh}->prepare($self->{cmd})
1043						\|\| return $self->dberr();
1044	0	0				$sth->execute()
1045						\|\| return $self->dberr();
1046
1047	0					my $ok = $self->dberr();
1048
1049	0	0				return $self->{dbh}->{mysql_insertid}
1050						if $self->{cmd} =~ /\bINSERT\b/i;
1051
1052	0	0				return $self->{dbh}->rows
1053						if $self->{cmd} =~ /\bUPDATE\b/i;
1054
1055	0	0				return $ok
1056						unless $self->{cmd} =~ /\bSELECT\b/i;
1057
1058	0					my $ret = $sth->fetchall_arrayref({});
1059	0	0				wantarray() ? @$ret : $ret;
1060						}
1061
1062						sub dberr {
1063	0			0		my $self = shift;
1064	0		0			$self->{err} = $self->{dbh}->err \|\| 0;
1065	0		0			$self->{errstr} = $self->{dbh}->errstr \|\| "";
1066
1067	0					my $die = $self->{DIE};
1068	0	0				if ($self->{err} == 1062) {
1069	0	0				return if $self->{dups} == $DB::Ent::DUPSQUIET;
1070	0	0				$die = undef if $self->{dups} == $DB::Ent::DUPSWARN;
1071						}
1072	0	0				if ($self->{err}) {
1073	0	0				$self->dbcmd() unless $self->{debug} > 0;
1074	0	0	0			$die && die($self->{errstr}) \|\| warn($self->{errstr});
1075						}
1076	0					!$self->{err};
1077						}
1078
1079						sub dbcmd {
1080	0			0		my $self = shift;
1081	0		0			local $_ = shift \|\| $self->{cmd};
1082
1083	0					s/^\s*/> /mg; s/\t/ /g;
	0
1084	0					$_ = sprintf("%s\n%s\n", ln("db->x()"), $_);
1085
1086	0	0				print unless defined wantarray; $_;
	0
1087						}
1088
1089						sub ln {
1090	0			0		my $title = shift;
1091	0		0			my $wd = shift \|\| 60;
1092	0					my $ln = "-" x $wd;
1093	0	0				return $title ? substr("--- $title $ln", 0, $wd) : $ln;
1094						}
1095
1096						=head1 AUTHOR
1097
1098						Erick Calder
1099
1100						=head1 SUPPORT
1101
1102						For help and thank you notes, e-mail the author directly. To report a bug, submit a patch or add to our wishlist please visit the CPAN bug manager at: F
1103
1104						=head1 AVAILABILITY
1105
1106						The latest version of the tarball, RPM and SRPM may always be found at: F Additionally the module is available from CPAN.
1107
1108						=head1 SEE ALSO
1109
1110						L, L.
1111
1112						=head1 LICENCE AND COPYRIGHT
1113
1114						Copyright (c) 2002-2003 Erick Calder.
1115
1116						This product is free and distributed under the Gnu Public License (GPL). A copy of this license was included in this distribution in a file called LICENSE. If for some reason, this file was not included, please see F to obtain a copy of this license.
1117
1118						$Id: Ent.pm,v 1.63 2003/06/24 03:58:11 ekkis Exp $
1119
1120						=cut
1121
1122						1; # yipiness :)