From: Christopher H. Laco Date: Sun, 21 May 2006 01:11:23 +0000 (+0000) Subject: Initial import X-Git-Tag: v0.04000~16 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=963a69a53d192e2fb73de90d9df6484e0b973657;p=p5sagit%2FClass-Accessor-Grouped.git Initial import --- diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..751c6b3 --- /dev/null +++ b/Build.PL @@ -0,0 +1,14 @@ +#!/usr/bin/perl +use warnings; +use strict; +use Module::Build; + +Module::Build->new( + module_name => 'Class::Accessor::Grouped', + license => 'perl', + requires => { + Carp => 0 + }, + create_makefile_pl => 'passthrough', + create_readme => 1, +)->create_build_script; diff --git a/Changes b/Changes new file mode 100644 index 0000000..9e19be1 --- /dev/null +++ b/Changes @@ -0,0 +1,4 @@ +Revision history for Class::Accessor::Grouped. + +0.01 2006-05-20 21:21:46 + - initial release diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..a3b707b --- /dev/null +++ b/MANIFEST @@ -0,0 +1,10 @@ +Build.PL +Changes +lib/Class/Accessor/Grouped.pm +MANIFEST This list of files +MANIFEST.SKIP +t/pod-coverage.t +t/pod.t +META.yml +Makefile.PL +README diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..dc85d7a --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,34 @@ +# Avoid version control files. +\bRCS\b +\bCVS\b +,v$ +,B$ +,D$ +\B\.svn\b +aegis.log$ +\bconfig$ +\bbuild$ + +# Avoid Makemaker generated and utility files. +\bMakefile$ +\bblib +\bMakeMaker-\d +\bpm_to_blib$ +\bblibdirs$ + +# Avoid Module::Build generated and utility files. +\bBuild$ +\b_build + +# Avoid temp and backup files. +~$ +\.gz$ +\.old$ +\.bak$ +\.swp$ +\.tdy$ +\#$ +\b\.# + +# Avoid author test files. +\bpod-spelling.t$ diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm new file mode 100644 index 0000000..78fb3df --- /dev/null +++ b/lib/Class/Accessor/Grouped.pm @@ -0,0 +1,283 @@ +package Class::Accessor::Grouped; +use strict; +use warnings; +use Carp::Clan; +use vars qw($VERSION); + +$VERSION = '0.01'; + +=head1 NAME + +Class:Accessor::Grouped- Lets you build groups of accessors + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +This class lets you build groups of accessors that will call different +getters and setters. + +=head1 METHODS + +=head2 mk_group_accessors + +=over 4 + +=item Arguments: $group, @fieldspec + +Returns: none + +=back + +Creates a set of accessors in a given group. + +$group is the name of the accessor group for the generated accessors; they +will call get_$group($field) on get and set_$group($field, $value) on set. + +@fieldspec is a list of field/accessor names; if a fieldspec is a scalar +this is used as both field and accessor name, if a listref it is expected to +be of the form [ $accessor, $field ]. + +=cut + +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) = @_; + my $class = ref $self || $self; + + # So we don't have to do lots of lookups inside the loop. + $maker = $self->can($maker) unless ref $maker; + + foreach my $field (@fields) { + if( $field eq 'DESTROY' ) { + carp("Having a data accessor named DESTROY in ". + "'$class' is unwise."); + } + + my $name = $field; + + ($name, $field) = @$field if ref $field; + + my $accessor = $self->$maker($group, $field); + my $alias = "_${name}_accessor"; + + #warn "$class $group $field $alias"; + + *{$class."\:\:$name"} = $accessor; + #unless defined &{$class."\:\:$field"} + + *{$class."\:\:$alias"} = $accessor; + #unless defined &{$class."\:\:$alias"} + } + } +} + +=head2 mk_group_ro_accessors + +=over 4 + +=item Arguments: $group, @fieldspec + +Returns: none + +=back + +Creates a set of read only accessors in a given group. Identical to + but accessors will throw an error if passed a value +rather than setting the value. + +=cut + +sub mk_group_ro_accessors { + my($self, $group, @fields) = @_; + + $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields); +} + +=head2 mk_group_wo_accessors + +=over 4 + +=item Arguments: $group, @fieldspec + +Returns: none + +=back + +Creates a set of write only accessors in a given group. Identical to + but accessors will throw an error if not passed a +value rather than getting the value. + +=cut + +sub mk_group_wo_accessors { + my($self, $group, @fields) = @_; + + $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields); +} + +=head2 make_group_accessor + +=over 4 + +=item Arguments: $group, $field + +Returns: $sub (\CODE) + +=back + +Returns a single accessor in a given group; called by mk_group_accessors +for each entry in @fieldspec. + +=cut + +sub make_group_accessor { + my ($class, $group, $field) = @_; + + my $set = "set_$group"; + my $get = "get_$group"; + + # Build a closure around $field. + return sub { + my $self = shift; + + if(@_) { + return $self->$set($field, @_); + } + else { + return $self->$get($field); + } + }; +} + +=head2 make_group_ro_accessor + +=over 4 + +=item Arguments: $group, $field + +Returns: $sub (\CODE) + +=back + +Returns a single read-only accessor in a given group; called by +mk_group_ro_accessors for each entry in @fieldspec. + +=cut + +sub make_group_ro_accessor { + my($class, $group, $field) = @_; + + my $get = "get_$group"; + + return sub { + my $self = shift; + + if(@_) { + my $caller = caller; + croak("'$caller' cannot alter the value of '$field' on ". + "objects of class '$class'"); + } + else { + return $self->$get($field); + } + }; +} + +=head2 make_group_wo_accessor + +=over 4 + +=item Arguments: $group, $field + +Returns: $sub (\CODE) + +=back + +Returns a single write-only accessor in a given group; called by +mk_group_wo_accessors for each entry in @fieldspec. + +=cut + +sub make_group_wo_accessor { + my($class, $group, $field) = @_; + + my $set = "set_$group"; + + return sub { + my $self = shift; + + unless (@_) { + my $caller = caller; + croak("'$caller' cannot access the value of '$field' on ". + "objects of class '$class'"); + } + else { + return $self->$set($field, @_); + } + }; +} + +=head2 get_simple + +=over 4 + +=item Arguments: $field + +Returns: $value + +=back + +Simple getter for hash-based objects which returns the value for the field +name passed as an argument. + +=cut + +sub get_simple { + my ($self, $get) = @_; + return $self->{$get}; +} + +=head2 set_simple + +=over 4 + +=item Arguments: $field, $new_value + +Returns: $new_value + +=back + +Simple setter for hash-based objects which sets and then returns the value +for the field name passed as an argument. + +=cut + +sub set_simple { + my ($self, $set, $val) = @_; + return $self->{$set} = $val; +} + +1; + +=head1 AUTHORS + +Matt S. Trout + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + diff --git a/t/pod-coverage.t b/t/pod-coverage.t new file mode 100644 index 0000000..2c5ca56 --- /dev/null +++ b/t/pod-coverage.t @@ -0,0 +1,4 @@ +use Test::More; +eval "use Test::Pod::Coverage 1.00"; +plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; +all_pod_coverage_ok(); diff --git a/t/pod-spelling.t b/t/pod-spelling.t new file mode 100644 index 0000000..550c11f --- /dev/null +++ b/t/pod-spelling.t @@ -0,0 +1,23 @@ +use Test::More; +eval 'use Test::Spelling 0.11'; +plan skip_all => 'Test::Spelling 0.11 not installed' if $@; +plan skip_all => 'set TEST_SPELLING to enable this test' unless $ENV{TEST_SPELLING}; + +set_spell_cmd('aspell list'); + +add_stopwords(); + +all_pod_files_spelling_ok(); + +__DATA__ +Bowden +Raygun +isa +mst +behaviour +further +overridable +Laco +Pauley +claco +stylings diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..437887a --- /dev/null +++ b/t/pod.t @@ -0,0 +1,4 @@ +use Test::More; +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; +all_pod_files_ok();