package Class::InheritDefaults; use strict; use base qw(Class::Data::Inheritable); # Class::InheritDefaults --- a universal base class with inhertiable # default values and automatic generation # of accessor methods # Copyright (C) 2006 Stefan Schwarzkopf # # 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., 51 Franklin St, Fifth Floor, Boston, MA 02110, USA sub new { my $invocant = shift; my $class = ref($invocant) || $invocant; my $self = {}; bless $self, $class; my %defaults = %{$class->defaults}; $self->_init(%defaults, @_); return $self; } sub init (@) { shift; my ($class, undef, undef) = caller; my %newdefaults = @_; my $defref = $class->defaults || {}; my %olddefaults = %{$defref}; while (my ($key, $value) = each %newdefaults) { if (ref($olddefaults{$key}) eq 'HASH') { my %newkey = %{$olddefaults{$key}}; while (my ($skey, $svalue) = each %{$value}) { $newkey{$skey} = $svalue; } $olddefaults{$key} = \%newkey; } else { $olddefaults{$key} = $value; } } $class->defaults(\%olddefaults); for my $field (keys %newdefaults) { my $slot = $class . "::$field"; no strict "refs"; *$slot = sub { my $self = shift; $self->{$slot} = shift if @_; return $self->{$slot}; }; } } sub _init { my $self = shift; my %args = @_; $self->$_($args{$_}) for keys %args; } Class::InheritDefaults->mk_classdata('defaults'); Class::InheritDefaults->init(); 1;