← Back to branch summary

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

« back to all changes in this revision

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

  • Committer: Package Import Robot
  • Author(s): Fabrizio Regalli, Ansgar Burchardt, Salvatore Bonaccorso, Fabrizio Regalli
  • Date: 2011-12-01 23:52:13 UTC
  • mfrom: (1.1.11)
  • Revision ID: package-import@ubuntu.com-20111201235213-nppamlddtxqzgo5e
Tags: 0.10004-1
[ Ansgar Burchardt ]
* debian/control: Convert Vcs-* fields to Git.

[ Salvatore Bonaccorso ]
* debian/copyright: Replace DEP5 Format-Specification URL from
  svn.debian.org to anonscm.debian.org URL.

[ Fabrizio Regalli ]
* Imported Upstream version 0.10004
* Update d/copyright to latest .174 revision of DEP-5 format
* Fixed missing-license-text-in-dep5-copyright lintian message
* Added version (>= 1.11) to libclass-xsaccessor-perl dependency
* Added version (>= 0.05) to libsub-name-perl dependency
* Added libdevel-hide-perl as B-D-I

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/Class/Accessor/Grouped.pm
13
13
  }
14
14
}
15
15
 
16
 
our $VERSION = '0.10003';
 
16
our $VERSION = '0.10004';
17
17
$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
18
18
 
19
19
# when changing minimum version don't forget to adjust L</PERFORMANCE> and
97
97
 
98
98
=head2 mk_group_accessors
99
99
 
100
 
 __PACKAGE__->mk_group_accessors(simple => 'hair_length');
 
100
 __PACKAGE__->mk_group_accessors(simple => 'hair_length', [ hair_color => 'hc' ]);
101
101
 
102
102
=over 4
103
103
 
131
131
 
132
132
=head2 mk_group_ro_accessors
133
133
 
134
 
 __PACKAGE__->mk_group_ro_accessors(simple => 'birthdate');
 
134
 __PACKAGE__->mk_group_ro_accessors(simple => 'birthdate', [ social_security_number => 'ssn' ]);
135
135
 
136
136
=over 4
137
137
 
155
155
 
156
156
=head2 mk_group_wo_accessors
157
157
 
158
 
 __PACKAGE__->mk_group_wo_accessors(simple => 'lie');
 
158
 __PACKAGE__->mk_group_wo_accessors(simple => 'lie', [ subject => 'subj' ]);
159
159
 
160
160
=over 4
161
161
 
177
177
    $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
178
178
}
179
179
 
180
 
=head2 make_group_accessor
181
 
 
182
 
 __PACKAGE__->make_group_accessor(simple => 'hair_length', 'hair_length');
183
 
 
184
 
=over 4
185
 
 
186
 
=item Arguments: $group, $field, $method
187
 
 
188
 
Returns: \&accessor_coderef ?
189
 
 
190
 
=back
191
 
 
192
 
Called by mk_group_accessors for each entry in @fieldspec. Either returns
193
 
a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
194
 
C<undef> if it elects to install the coderef on its own.
195
 
 
196
 
=cut
197
 
 
198
 
sub make_group_accessor { $gen_accessor->('rw', @_) }
199
 
 
200
 
=head2 make_group_ro_accessor
201
 
 
202
 
 __PACKAGE__->make_group_ro_accessor(simple => 'birthdate', 'birthdate');
203
 
 
204
 
=over 4
205
 
 
206
 
=item Arguments: $group, $field, $method
207
 
 
208
 
Returns: \&accessor_coderef ?
209
 
 
210
 
=back
211
 
 
212
 
Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
213
 
a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
214
 
C<undef> if it elects to install the coderef on its own.
215
 
 
216
 
=cut
217
 
 
218
 
sub make_group_ro_accessor { $gen_accessor->('ro', @_) }
219
 
 
220
 
=head2 make_group_wo_accessor
221
 
 
222
 
 __PACKAGE__->make_group_wo_accessor(simple => 'lie', 'lie');
223
 
 
224
 
=over 4
225
 
 
226
 
=item Arguments: $group, $field, $method
227
 
 
228
 
Returns: \&accessor_coderef ?
229
 
 
230
 
=back
231
 
 
232
 
Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
233
 
a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
234
 
C<undef> if it elects to install the coderef on its own.
235
 
 
236
 
=cut
237
 
 
238
 
sub make_group_wo_accessor { $gen_accessor->('wo', @_) }
239
 
 
240
180
=head2 get_simple
241
181
 
242
182
=over 4
422
362
    return $_[0]->set_inherited($_[1], $_[2]);
423
363
};
424
364
 
 
365
=head1 INTERNAL METHODS
 
366
 
 
367
These methods are documented for clarity, but are never meant to be called
 
368
directly, and are not really meant for overriding either.
 
369
 
425
370
=head2 get_super_paths
426
371
 
427
 
Returns a list of 'parent' or 'super' class names that the current class inherited from.
 
372
Returns a list of 'parent' or 'super' class names that the current class
 
373
inherited from. This is what drives the traversal done by L</get_inherited>.
428
374
 
429
375
=cut
430
376
 
432
378
    return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
433
379
};
434
380
 
 
381
=head2 make_group_accessor
 
382
 
 
383
 __PACKAGE__->make_group_accessor('simple', 'hair_length', 'hair_length');
 
384
 __PACKAGE__->make_group_accessor('simple', 'hc', 'hair_color');
 
385
 
 
386
=over 4
 
387
 
 
388
=item Arguments: $group, $field, $accessor
 
389
 
 
390
Returns: \&accessor_coderef ?
 
391
 
 
392
=back
 
393
 
 
394
Called by mk_group_accessors for each entry in @fieldspec. Either returns
 
395
a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
 
396
C<undef> if it elects to install the coderef on its own.
 
397
 
 
398
=cut
 
399
 
 
400
sub make_group_accessor { $gen_accessor->('rw', @_) }
 
401
 
 
402
=head2 make_group_ro_accessor
 
403
 
 
404
 __PACKAGE__->make_group_ro_accessor('simple', 'birthdate', 'birthdate');
 
405
 __PACKAGE__->make_group_ro_accessor('simple', 'ssn', 'social_security_number');
 
406
 
 
407
=over 4
 
408
 
 
409
=item Arguments: $group, $field, $accessor
 
410
 
 
411
Returns: \&accessor_coderef ?
 
412
 
 
413
=back
 
414
 
 
415
Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
 
416
a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
 
417
C<undef> if it elects to install the coderef on its own.
 
418
 
 
419
=cut
 
420
 
 
421
sub make_group_ro_accessor { $gen_accessor->('ro', @_) }
 
422
 
 
423
=head2 make_group_wo_accessor
 
424
 
 
425
 __PACKAGE__->make_group_wo_accessor('simple', 'lie', 'lie');
 
426
 __PACKAGE__->make_group_wo_accessor('simple', 'subj', 'subject');
 
427
 
 
428
=over 4
 
429
 
 
430
=item Arguments: $group, $field, $accessor
 
431
 
 
432
Returns: \&accessor_coderef ?
 
433
 
 
434
=back
 
435
 
 
436
Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
 
437
a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
 
438
C<undef> if it elects to install the coderef on its own.
 
439
 
 
440
=cut
 
441
 
 
442
sub make_group_wo_accessor { $gen_accessor->('wo', @_) }
 
443
 
 
444
 
435
445
=head1 PERFORMANCE
436
446
 
437
447
To provide total flexibility L<Class::Accessor::Grouped> calls methods
532
542
    delete $INC{'Sub/Name.pm'};   # because older perls suck
533
543
    $@;
534
544
  };
535
 
  *__CAG_NO_SUBNAME = $err
 
545
  *__CAG_ENV__::NO_SUBNAME = $err
536
546
    ? sub () { $err }
537
547
    : sub () { 0 }
538
548
  ;
548
558
    delete $INC{'Class/XSAccessor.pm'};
549
559
    $@;
550
560
  };
551
 
  *__CAG_NO_CXSA = $err
 
561
  *__CAG_ENV__::NO_CXSA = $err
552
562
    ? sub () { $err }
553
563
    : sub () { 0 }
554
564
  ;
555
565
 
556
566
 
557
 
  *__CAG_BROKEN_GOTO = ($] < '5.008009')
558
 
    ? sub () { 1 }
559
 
    : sub () { 0 }
560
 
  ;
561
 
 
562
 
 
563
 
  *__CAG_UNSTABLE_DOLLARAT = ($] < '5.013002')
564
 
    ? sub () { 1 }
565
 
    : sub () { 0 }
566
 
  ;
567
 
 
568
 
 
569
 
  *__CAG_TRACK_UNDEFER_FAIL = (
 
567
  *__CAG_ENV__::BROKEN_GOTO = ($] < '5.008009')
 
568
    ? sub () { 1 }
 
569
    : sub () { 0 }
 
570
  ;
 
571
 
 
572
 
 
573
  *__CAG_ENV__::UNSTABLE_DOLLARAT = ($] < '5.013002')
 
574
    ? sub () { 1 }
 
575
    : sub () { 0 }
 
576
  ;
 
577
 
 
578
 
 
579
  *__CAG_ENV__::TRACK_UNDEFER_FAIL = (
570
580
    $INC{'Test/Builder.pm'} || $INC{'Test/Builder2.pm'}
571
581
      and
572
582
    $0 =~ m|^ x?t / .+ \.t $|x
578
588
# Autodetect unless flag supplied
579
589
my $xsa_autodetected;
580
590
if (! defined $USE_XS) {
581
 
  $USE_XS = __CAG_NO_CXSA ? 0 : 1;
 
591
  $USE_XS = __CAG_ENV__::NO_CXSA ? 0 : 1;
582
592
  $xsa_autodetected++;
583
593
}
584
594
 
663
673
  # Thus the final method (properly labeled and all) is installed in the
664
674
  # calling-package's namespace
665
675
  if ($USE_XS and $group eq 'simple') {
666
 
    die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_NO_CXSA )
667
 
      if __CAG_NO_CXSA;
 
676
    die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_ENV__::NO_CXSA )
 
677
      if __CAG_ENV__::NO_CXSA;
668
678
 
669
679
    my ($expected_cref, $cached_implementation);
670
680
    my $ret = $expected_cref = sub {
727
737
 
728
738
        # older perls segfault if the cref behind the goto throws
729
739
        # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
730
 
        return $resolved_implementation->(@_) if __CAG_BROKEN_GOTO;
 
740
        return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
731
741
 
732
742
        goto $resolved_implementation;
733
743
      }
734
744
 
735
 
      if (__CAG_TRACK_UNDEFER_FAIL) {
 
745
      if (__CAG_ENV__::TRACK_UNDEFER_FAIL) {
736
746
        my $deferred_calls_seen = do {
737
747
          no strict 'refs';
738
748
          \%{"${current_class}::__cag_deferred_xs_shim_invocations"}
769
779
 
770
780
      # older perls segfault if the cref behind the goto throws
771
781
      # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
772
 
      return $resolved_implementation->(@_) if __CAG_BROKEN_GOTO;
 
782
      return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
773
783
 
774
784
      goto $resolved_implementation;
775
785
    };
779
789
  }
780
790
 
781
791
  # no Sub::Name - just install the coderefs directly (compiling every time)
782
 
  elsif (__CAG_NO_SUBNAME) {
 
792
  elsif (__CAG_ENV__::NO_SUBNAME) {
783
793
    my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
784
794
      $maker_templates->{$type}{pp_code}->($group, $field);
785
795
 
786
796
    no warnings 'redefine';
787
 
    local $@ if __CAG_UNSTABLE_DOLLARAT;
 
797
    local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT;
788
798
    eval "sub ${class}::${methname} { $src }";
789
799
 
790
800
    undef;  # so that no further attempt will be made to install anything
796
806
      my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
797
807
        $maker_templates->{$type}{pp_code}->($group, $field);
798
808
 
799
 
      local $@ if __CAG_UNSTABLE_DOLLARAT;
 
809
      local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT;
800
810
      eval "sub { my \$dummy; sub { \$dummy if 0; $src } }" or die $@;
801
811
    })->()
802
812
  }