~ubuntu-branches/ubuntu/wily/libclass-accessor-grouped-perl/wily

Viewing changes to lib/Class/Accessor/Grouped.pm

Committer: Bazaar Package Importer
Author(s): gregor herrmann, Ansgar Burchardt, Antony Gelberg, gregor herrmann
Date: 2011-01-24 18:49:35 UTC
mfrom: (1.1.9 upstream)
Revision ID: james.westby@ubuntu.com-20110124184935-j6jm3u3vn42tklq0

Tags: 0.10002-1

[ Ansgar Burchardt ]
* Update my email address.

[ Antony Gelberg ]
* New upstream release

[ gregor herrmann ]
* debian/copyright: update formatting and list of packagers.
* debian/control: update build dependencies.

Show diffs side-by-side

added added

removed removed

lib/Class/Accessor/Grouped.pm

use Carp ();

use Scalar::Util ();

use MRO::Compat;

use Sub::Name ();

our $VERSION = '0.09006';

$VERSION = eval $VERSION;

# when changing minimum version don't forget to adjust L</PERFROMANCE> as well

our $__minimum_xsa_version = '1.06';

our $VERSION = '0.10002';

$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases

# when changing minimum version don't forget to adjust L</PERFORMANCE> and

# the Makefile.PL as well

our $__minimum_xsa_version;

BEGIN {

$__minimum_xsa_version = '1.11';

}

our $USE_XS;

# the unless defined is here so that we can override the value

$USE_XS = $ENV{CAG_USE_XS}

unless defined $USE_XS;

my $xsa_loaded;

my $load_xsa = sub {

return if $xsa_loaded++;

require Class::XSAccessor;

Class::XSAccessor->VERSION($__minimum_xsa_version);

};

my $use_xs = sub {

if (defined $USE_XS) {

$load_xsa->() if ($USE_XS && ! $xsa_loaded);

return $USE_XS;

}

$USE_XS = 0;

# Class::XSAccessor is segfaulting on win32, in some

# esoteric heavily-threaded scenarios

# Win32 users can set $USE_XS/CAG_USE_XS to try to use it anyway

if ($^O ne 'MSWin32') {

local $@;

eval { $load_xsa->(); $USE_XS = 1 };

}

return $USE_XS;

};

# Yes this method is undocumented

# Yes it should be a private coderef like all the rest at the end of this file

# No we can't do that (yet) because the DBIC-CDBI compat layer overrides it

# %$*@!?&!&#*$!!!

sub _mk_group_accessors {

my($self, $maker, $group, @fields) = @_;

my $class = Scalar::Util::blessed $self || $self;

no strict 'refs';

no warnings 'redefine';

# So we don't have to do lots of lookups inside the loop.

$maker = $self->can($maker) unless ref $maker;

foreach (@fields) {

if( $_ eq 'DESTROY' ) {

Carp::carp("Having a data accessor named DESTROY in ".

"'$class' is unwise.");

}

my ($name, $field) = (ref $_)

? (@$_)

: ($_, $_)

;

my $alias = "_${name}_accessor";

for my $meth ($name, $alias) {

# the maker may elect to not return anything, meaning it already

# installed the coderef for us (e.g. lack of Sub::Name)

my $cref = $self->$maker($group, $field, $meth)

or next;

my $fq_meth = "${class}::${meth}";

*$fq_meth = Sub::Name::subname($fq_meth, $cref);

#unless defined &{$class."\:\:$field"}

}

};

# coderef is setup at the end for clarity

my $gen_accessor;

=head1 NAME

105

=cut

106

107

sub mk_group_accessors {

my ($self, $group, @fields) = @_;

$self->_mk_group_accessors('make_group_accessor', $group, @fields);

return;

}

{

no strict 'refs';

no warnings 'redefine';

sub _mk_group_accessors {

my($self, $maker, $group, @fields) = @_;

100

my $class = Scalar::Util::blessed $self || $self;

101

102

# So we don't have to do lots of lookups inside the loop.

103

$maker = $self->can($maker) unless ref $maker;

104

105

foreach (@fields) {

106

if( $_ eq 'DESTROY' ) {

107

Carp::carp("Having a data accessor named DESTROY in ".

108

"'$class' is unwise.");

109

}

110

111

my ($name, $field) = (ref $_)

112

? (@$_)

113

: ($_, $_)

114

;

115

116

my $alias = "_${name}_accessor";

117

118

for my $meth ($name, $alias) {

119

120

# the maker may elect to not return anything, meaning it already

121

# installed the coderef for us

122

my $cref = $self->$maker($group, $field, $meth)

123

or next;

124

125

my $fq_meth = join('::', $class, $meth);

126

127

*$fq_meth = Sub::Name::subname($fq_meth, $cref);

128

#unless defined &{$class."\:\:$field"}

129

}

130

}

131

}

108

my ($self, $group, @fields) = @_;

109

110

$self->_mk_group_accessors('make_group_accessor', $group, @fields);

111

return;

132

112

}

133

113

134

114

=head2 mk_group_ro_accessors

191

171

192

172

=cut

193

173

194

sub make_group_accessor {

195

my ($class, $group, $field, $name) = @_;

196

197

if ( $group eq 'simple' && $use_xs->() ) {

198

Class::XSAccessor->import({

199

replace => 1,

200

class => $class,

201

accessors => {

202

$name => $field,

203

204

});

205

return;

206

}

207

208

my $set = "set_$group";

209

my $get = "get_$group";

210

211

$field =~ s/'/\\'/g;

212

213

# eval for faster fastiness

214

my $code = eval "sub {

215

if(\@_ > 1) {

216

return shift->$set('$field', \@_);

217

}

218

else {

219

return shift->$get('$field');

220

}

221

};";

222

Carp::croak $@ if $@;

223

224

return $code;

225

}

174

sub make_group_accessor { $gen_accessor->('rw', @_) }

226

175

227

176

=head2 make_group_ro_accessor

228

177

240

189

241

190

=cut

242

191

243

sub make_group_ro_accessor {

244

my($class, $group, $field, $name) = @_;

245

246

if ( $group eq 'simple' && $use_xs->() ) {

247

Class::XSAccessor->import({

248

replace => 1,

249

class => $class,

250

getters => {

251

$name => $field,

252

253

});

254

return;

255

}

256

257

my $get = "get_$group";

258

259

$field =~ s/'/\\'/g;

260

261

my $code = eval "sub {

262

if(\@_ > 1) {

263

my \$caller = caller;

264

Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".

265

\"objects of class '$class'\");

266

}

267

else {

268

return shift->$get('$field');

269

}

270

};";

271

Carp::croak $@ if $@;

272

273

return $code;

274

}

192

sub make_group_ro_accessor { $gen_accessor->('ro', @_) }

275

193

276

194

=head2 make_group_wo_accessor

277

195

289

207

290

208

=cut

291

209

292

sub make_group_wo_accessor {

293

my($class, $group, $field, $name) = @_;

294

295

if ( $group eq 'simple' && $use_xs->() ) {

296

Class::XSAccessor->import({

297

replace => 1,

298

class => $class,

299

setters => {

300

$name => $field,

301

302

});

303

return;

304

}

305

306

my $set = "set_$group";

307

308

$field =~ s/'/\\'/g;

309

310

my $code = eval "sub {

311

unless (\@_ > 1) {

312

my \$caller = caller;

313

Carp::croak(\"'\$caller' cannot access the value of '$field' on \".

314

\"objects of class '$class'\");

315

}

316

else {

317

return shift->$set('$field', \@_);

318

}

319

};";

320

Carp::croak $@ if $@;

321

322

return $code;

323

}

210

sub make_group_wo_accessor { $gen_accessor->('wo', @_) }

324

211

325

212

=head2 get_simple

326

213

338

225

=cut

339

226

340

227

sub get_simple {

341

return $_[0]->{$_[1]};

228

return $_[0]->{$_[1]};

342

229

}

343

230

344

231

=head2 set_simple

357

244

=cut

358

245

359

246

sub set_simple {

360

return $_[0]->{$_[1]} = $_[2];

247

return $_[0]->{$_[1]} = $_[2];

361

248

}

362

249

363

250

382

269

sub get_inherited {

383

270

my $class;

384

271

385

if ( ($class = ref $_[0]) && Scalar::Util::blessed $_[0]) {

272

if ( defined( $class = Scalar::Util::blessed $_[0] ) ) {

386

273

if (Scalar::Util::reftype $_[0] eq 'HASH') {

387

274

return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};

388

275

}

395

282

}

396

283

397

284

no strict 'refs';

398

no warnings qw/uninitialized/;

285

no warnings 'uninitialized';

399

286

400

287

my $cag_slot = '::__cag_'. $_[1];

401

288

return ${$class.$cag_slot} if defined(${$class.$cag_slot});

435

322

=cut

436

323

437

324

sub set_inherited {

438

if (Scalar::Util::blessed $_[0]) {

325

if (defined Scalar::Util::blessed $_[0]) {

439

326

if (Scalar::Util::reftype $_[0] eq 'HASH') {

440

327

return $_[0]->{$_[1]} = $_[2];

441

328

} else {

498

385

local $^W = 0;

499

386

require Class::Inspector;

500

387

if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {

501

eval "use $_[2]";

388

eval "require $_[2]";

502

389

503

390

Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;

504

391

};

517

404

return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};

518

405

};

519

406

520

521

522

407

=head1 PERFORMANCE

523

408

524

409

To provide total flexibility L<Class::Accessor::Grouped> calls methods

525

410

internally while performing get/set actions, which makes it noticeably

526

411

slower than similar modules. To compensate, this module will automatically

527

412

use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group

528

accessors, if L<< Class::XSAccessor >= 1.06|Class::XSAccessor >> is

529

available on your system.

413

accessors if this module is available on your system.

530

414

531

415

=head2 Benchmark

532

416

533

417

This is the result of a set/get/set loop benchmark on perl 5.12.1 with

534

418

thread support, showcasing most popular accessor builders: L<Moose>, L<Mouse>,

535

L<CAF|Class::Accessor::Fast>, L<CAF_XS|Class::Accessor::Fast::XS>

536

and L<XSA|Class::XSAccessor>:

419

L<Moo>, L<CAF|Class::Accessor::Fast>, L<CAF_XS|Class::Accessor::Fast::XS>,

420

L<XSA|Class::XSAccessor>, and L<CAF_XSA|Class::XSAccessor::Compat>:

537

421

538

Rate CAG moOse CAF HANDMADE CAF_XS moUse_XS CAG_XS XSA

539

CAG 1777/s -- -27% -29% -36% -62% -67% -72% -73%

540

moOse 2421/s 36% -- -4% -13% -48% -55% -61% -63%

541

CAF 2511/s 41% 4% -- -10% -47% -53% -60% -61%

542

HANDMADE 2791/s 57% 15% 11% -- -41% -48% -56% -57%

543

CAF_XS 4699/s 164% 94% 87% 68% -- -13% -25% -28%

544

moUse_XS 5375/s 203% 122% 114% 93% 14% -- -14% -18%

545

CAG_XS 6279/s 253% 159% 150% 125% 34% 17% -- -4%

546

XSA 6515/s 267% 169% 159% 133% 39% 21% 4% --

422

Rate CAG moOse CAF moUse moo HANDMADE CAF_XS moUse_XS moo_XS CAF_XSA XSA CAG_XS

423

CAG 169/s -- -21% -24% -32% -32% -34% -59% -63% -67% -67% -67% -67%

424

moOse 215/s 27% -- -3% -13% -13% -15% -48% -53% -58% -58% -58% -58%

425

CAF 222/s 31% 3% -- -10% -10% -13% -46% -52% -57% -57% -57% -57%

426

moUse 248/s 46% 15% 11% -- -0% -3% -40% -46% -52% -52% -52% -52%

427

moo 248/s 46% 15% 11% 0% -- -3% -40% -46% -52% -52% -52% -52%

428

HANDMADE 255/s 50% 18% 14% 3% 3% -- -38% -45% -50% -51% -51% -51%

429

CAF_XS 411/s 143% 91% 85% 66% 66% 61% -- -11% -20% -20% -21% -21%

430

moUse_XS 461/s 172% 114% 107% 86% 86% 81% 12% -- -10% -11% -11% -11%

431

moo_XS 514/s 204% 139% 131% 107% 107% 102% 25% 12% -- -0% -1% -1%

432

CAF_XSA 516/s 205% 140% 132% 108% 108% 103% 26% 12% 0% -- -0% -0%

433

XSA 519/s 206% 141% 133% 109% 109% 104% 26% 13% 1% 0% -- -0%

434

CAG_XS 519/s 206% 141% 133% 109% 109% 104% 26% 13% 1% 0% 0% --

547

435

548

436

Benchmark program is available in the root of the

549

437

L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:

550

438

551

439

=head2 Notes on Class::XSAccessor

552

440

553

While L<Class::XSAccessor> works surprisingly well for the amount of black

554

magic it tries to pull off, it's still black magic. At present (Sep 2010)

555

the module is known to have problems on Windows under heavy thread-stress

556

(e.g. Win32+Apache+mod_perl). Thus for the time being L<Class::XSAccessor>

557

will not be used automatically if you are running under C<MSWin32>.

558

559

You can force the use of L<Class::XSAccessor> before creating a particular

560

C<simple> accessor by either manipulating the global variable

561

C<$Class::Accessor::Grouped::USE_XS>, or you can do so before runtime via the

441

You can force (or disable) the use of L<Class::XSAccessor> before creating a

442

particular C<simple> accessor by either manipulating the global variable

443

C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with

444

L<localization|perlfunc/local>, or you can do so before runtime via the

562

445

C<CAG_USE_XS> environment variable.

563

446

447

Since L<Class::XSAccessor> has no knowledge of L</get_simple> and

448

L</set_simple> this module does its best to detect if you are overriding

449

one of these methods and will fall back to using the perl version of the

450

accessor in order to maintain consistency. However be aware that if you

451

enable use of C<Class::XSAccessor> (automatically or explicitly), create

452

an object, invoke a simple accessor on that object, and B<then> manipulate

453

the symbol table to install a C<get/set_simple> override - you get to keep

454

all the pieces.

455

564

456

=head1 AUTHORS

565

457

566

458

Matt S. Trout <mst@shadowcatsystems.co.uk>

586

478

it under the same terms as perl itself.

587

479

588

480

=cut

481

482

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

483

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

484

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

485

486

# Here be many angry dragons

487

# (all code is in private coderefs since everything inherits CAG)

488

489

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

490

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

491

492

BEGIN {

493

494

die "Huh?! No minimum C::XSA version?!\n"

495

unless $__minimum_xsa_version;

496

497

local $@;

498

my $err;

499

500

501

$err = eval { require Sub::Name; 1; } ? undef : do {

502

delete $INC{'Sub/Name.pm'}; # because older perls suck

503

$@;

504

};

505

*__CAG_NO_SUBNAME = $err

506

? sub () { $err }

507

: sub () { 0 }

508

;

509

510

511

$err = eval {

512

require Class::XSAccessor;

513

Class::XSAccessor->VERSION($__minimum_xsa_version);

514

require Sub::Name;

515

516

} ? undef : do {

517

delete $INC{'Sub/Name.pm'}; # because older perls suck

518

delete $INC{'Class/XSAccessor.pm'};

519

$@;

520

};

521

*__CAG_NO_CXSA = $err

522

? sub () { $err }

523

: sub () { 0 }

524

;

525

526

527

*__CAG_BROKEN_GOTO = ($] < '5.008009')

528

? sub () { 1 }

529

: sub () { 0 }

530

;

531

532

533

*__CAG_UNSTABLE_DOLLARAT = ($] < '5.013002')

534

? sub () { 1 }

535

: sub () { 0 }

536

;

537

538

539

*__CAG_TRACK_UNDEFER_FAIL = (

540

$INC{'Test/Builder.pm'} || $INC{'Test/Builder2.pm'}

541

and

542

$0 =~ m|^ x?t / .+ \.t $|x

543

) ? sub () { 1 }

544

: sub () { 0 }

545

;

546

}

547

548

# Autodetect unless flag supplied

549

my $xsa_autodetected;

550

if (! defined $USE_XS) {

551

$USE_XS = __CAG_NO_CXSA ? 0 : 1;

552

$xsa_autodetected++;

553

}

554

555

my $maker_templates = {

556

rw => {

557

xs_call => 'accessors',

558

pp_code => sub {

559

my $set = "set_$_[0]";

560

my $get = "get_$_[0]";

561

my $field = $_[1];

562

$field =~ s/'/\\'/g;

563

564

565

\@_ != 1

566

? shift->$set('$field', \@_)

567

: shift->$get('$field')

568

569

570

571

ro => {

572

xs_call => 'getters',

573

pp_code => sub {

574

my $get = "get_$_[0]";

575

my $field = $_[1];

576

$field =~ s/'/\\'/g;

577

578

579

\@_ == 1

580

? shift->$get('$field')

581

: do {

582

my \$caller = caller;

583

my \$class = ref \$_[0] || \$_[0];

584

Carp::croak(\"'\$caller' cannot alter the value of '$field' \".

585

\"(read-only attributes of class '\$class')\");

586

}

587

588

589

590

wo => {

591

xs_call => 'setters',

592

pp_code => sub {

593

my $set = "set_$_[0]";

594

my $field = $_[1];

595

$field =~ s/'/\\'/g;

596

597

598

\@_ != 1

599

? shift->$set('$field', \@_)

600

: do {

601

my \$caller = caller;

602

my \$class = ref \$_[0] || \$_[0];

603

Carp::croak(\"'\$caller' cannot access the value of '$field' \".

604

\"(write-only attributes of class '\$class')\");

605

}

606

607

608

609

};

610

611

612

my ($accessor_maker_cache, $no_xsa_warned_classes);

613

614

# can't use pkg_gen to track this stuff, as it doesn't

615

# detect superclass mucking

616

my $original_simple_getter = __PACKAGE__->can ('get_simple');

617

my $original_simple_setter = __PACKAGE__->can ('set_simple');

618

619

# Note!!! Unusual signature

620

$gen_accessor = sub {

621

my ($type, $class, $group, $field, $methname) = @_;

622

if (my $c = Scalar::Util::blessed( $class )) {

623

$class = $c;

624

}

625

626

# When installing an XSA simple accessor, we need to make sure we are not

627

# short-circuiting a (compile or runtime) get_simple/set_simple override.

628

# What we do here is install a lazy first-access check, which will decide

629

# the ultimate coderef being placed in the accessor slot

630

631

# Also note that the *original* class will always retain this shim, as

632

# different branches inheriting from it may have different overrides.

633

# Thus the final method (properly labeled and all) is installed in the

634

# calling-package's namespace

635

if ($USE_XS and $group eq 'simple') {

636

die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_NO_CXSA )

637

if __CAG_NO_CXSA;

638

639

my ($expected_cref, $cached_implementation);

640

my $ret = $expected_cref = sub {

641

my $current_class = Scalar::Util::blessed( $_[0] ) || $_[0];

642

643

# $cached_implementation will be set only if the shim got

644

# 'around'ed, in which case it is handy to avoid re-running

645

# this block over and over again

646

my $resolved_implementation = $cached_implementation->{$current_class} || do {

647

if (

648

$current_class->can('get_simple') == $original_simple_getter

649

650

$current_class->can('set_simple') == $original_simple_setter

651

) {

652

# nothing has changed, might as well use the XS crefs

653

654

# note that by the time this code executes, we already have

655

# *objects* (since XSA works on 'simple' only by definition).

656

# If someone is mucking with the symbol table *after* there

657

# are some objects already - look! many, shiny pieces! :)

658

659

# The weird breeder thingy is because XSA does not have an

660

# interface returning *just* a coderef, without installing it

661

# anywhere :(

662

Class::XSAccessor->import(

663

replace => 1,

664

class => '__CAG__XSA__BREEDER__',

665

$maker_templates->{$type}{xs_call} => {

666

$methname => $field,

667

668

);

669

__CAG__XSA__BREEDER__->can($methname);

670

}

671

else {

672

if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) {

673

# not using Carp since the line where this happens doesn't mean much

674

warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class '

675

. "'$current_class' inheriting from '$class' due to an overriden get_simple and/or "

676

. "set_simple\n";

677

}

678

679

do {

680

# that's faster than local

681

$USE_XS = 0;

682

my $c = $gen_accessor->($type, $class, 'simple', $field, $methname);

683

$USE_XS = 1;

684

$c;

685

};

686

}

687

};

688

689

# if after this shim was created someone wrapped it with an 'around',

690

# we can not blindly reinstall the method slot - we will destroy the

691

# wrapper. Silently chain execution further...

692

if ( !$expected_cref or $expected_cref != $current_class->can($methname) ) {

693

694

# there is no point in re-determining it on every subsequent call,

695

# just store for future reference

696

$cached_implementation->{$current_class} ||= $resolved_implementation;

697

698

# older perls segfault if the cref behind the goto throws

699

# http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878

700

return $resolved_implementation->(@_) if __CAG_BROKEN_GOTO;

701

702

goto $resolved_implementation;

703

}

704

705

if (__CAG_TRACK_UNDEFER_FAIL) {

706

my $deferred_calls_seen = do {

707

no strict 'refs';

708

\%{"${current_class}::__cag_deferred_xs_shim_invocations"}

709

};

710

my @cframe = caller(0);

711

if (my $already_seen = $deferred_calls_seen->{$cframe[3]}) {

712

Carp::carp (

713

"Deferred version of method $cframe[3] invoked more than once (originally "

714

. "invoked at $already_seen). This is a strong indication your code has "

715

. 'cached the original ->can derived method coderef, and is using it instead '

716

. 'of the proper method re-lookup, causing performance regressions'

717

);

718

}

719

else {

720

$deferred_calls_seen->{$cframe[3]} = "$cframe[1] line $cframe[2]";

721

}

722

}

723

724

# install the resolved implementation into the code slot so we do not

725

# come here anymore (hopefully)

726

# since XSAccessor was available - so is Sub::Name

727

{

728

no strict 'refs';

729

no warnings 'redefine';

730

731

my $fq_name = "${current_class}::${methname}";

732

*$fq_name = Sub::Name::subname($fq_name, $resolved_implementation);

733

734

# need to update what the shim expects too *in case* its

735

# ->can was cached for some moronic reason

736

$expected_cref = $resolved_implementation;

737

Scalar::Util::weaken($expected_cref);

738

}

739

740

# older perls segfault if the cref behind the goto throws

741

# http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878

742

return $resolved_implementation->(@_) if __CAG_BROKEN_GOTO;

743

744

goto $resolved_implementation;

745

};

746

747

Scalar::Util::weaken($expected_cref); # to break the self-reference

748

$ret;

749

}

750

751

# no Sub::Name - just install the coderefs directly (compiling every time)

752

elsif (__CAG_NO_SUBNAME) {

753

my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=

754

$maker_templates->{$type}{pp_code}->($group, $field);

755

756

no warnings 'redefine';

757

local $@ if __CAG_UNSTABLE_DOLLARAT;

758

eval "sub ${class}::${methname} { $src }";

759

760

undef; # so that no further attempt will be made to install anything

761

}

762

763

# a coderef generator with a variable pad (returns a fresh cref on every invocation)

764

else {

765

($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do {

766

my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=

767

$maker_templates->{$type}{pp_code}->($group, $field);

768

769

local $@ if __CAG_UNSTABLE_DOLLARAT;

770

eval "sub { my \$dummy; sub { \$dummy if 0; $src } }" or die $@;

771

})->()

772

}

773

};

774

775

Older »