package WhcStd;

use 5.008;
use strict;
use warnings;
use Carp;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration use WhcStd ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.02';

our $counter = 0;
our %pnv;

# Preloaded methods go here.

sub allow {
        my (@accept) = @_;
        $pnv{$_} = 1 foreach (@accept) ;
        }

sub new {
        my ($class,@params) = @_ ;
        my %info;
        $counter++;
        set(\%info,@params);
        bless \%info,$class;
        }

sub set {
        my ($obj,@params) = @_;
        my %setup;
        if (ref($params[0]) eq "HASH") {
                %setup = %{$params[0]};
        } elsif (@params%2) {
                croak("Snuffed it in set ... ");
        } else {
                %setup = @params;
        }
        my ($p,$q) ;
        foreach $p (keys %setup) {
                $q = $p;
                $p =~ s/^-//;
                unless ($pnv{$p}) {
                        carp("Can't set $p. Not a valid property");
                } else {
                        $$obj{$p} = $setup{$q};
                        }
                }
        1;
        }

sub get {
        my ($obj,$what) = @_;
        unless ($pnv{$what}) {
                carp("Can't get $what. Not a valid property");
                return 0;
                }
        return $$obj{$what};
        }

sub AUTOLOAD {
        my ($obj,$value) = @_;
        our $AUTOLOAD;
        my ($dirn,$what) = ($AUTOLOAD =~ /.*:(...)(.*)/);
        return 1 if ($dirn eq "DES" and $what eq "TROY");
        if ($dirn eq "set") {
                unless ($pnv{$what}) {
                        carp("Can't set $what. Not a valid property");
                        return 0;
                        }
                $$obj{$what} = $value;
                return 1;
        }
        if ($dirn eq "get") {
                unless ($pnv{$what}) {
                        carp("Can't get $what. Not a valid property");
                        return 0;
                        }
                return $$obj{$what};
                }
        # Check for anything else ;-)
        carp ("No $AUTOLOAD; returing 0 ");
        0;
        }

1;
__END__

=head1 NAME

WhcStd - Perl extension for a standard object

=head1 SYNOPSIS

  use WhcStd;
  WhcStd::allow("prop1","prop2",.......);

        $t = new WhcStd();
        WhcStd::allow("prop1","prop2",.......);
        $object -> set("area", 200.0);

=head1 ABSTRACT

  This module provides a standard object interface allowing constructors,
  get and set methods and AUTOLOAD to allow for transparent property handling

=head1 DESCRIPTION

Perl has many varied idioms through which objects are properties can be defined.
This WhcStd class is a generalised object through which a predefined list of
properties can be set and accessed using standard hash table methods and also
AUTOLOADed methods.

The following may be used to define valid properties for all standard objects:
        WhcStd::allow("prop1","prop2",.......);

The following may be used to create an object:
        $t = new WhcStd();
        %start = ("area",30,"height",50); $t = new WhcStd(\%start);
        $t = new WhcStd(-area => 30,-height => 50);
Property names as defined by a previous call to WhcStd::allow

The following may be used to set a property:
        $object -> set("area", 200.0);
        $object -> set(-area => 200.0);
        %star = ("area",200.0); $object -> set(\%star);
        $object -> setarea(200.0);
Multiple properties may be set using any of the first three formats

The following may be used to get a property:
        $area = $object -> get("area");
        $area = $object -> getarea();

=head2 EXPORT

None by default.

=head1 SEE ALSO

The writing of this module is described on our web site at
http://www.wellho.net

Assistance is available via our forum at
http://www.opentalk.org.uk

=head1 AUTHOR

Graham Ellis, Well House Consultants

=head1 COPYRIGHT AND LICENSE

Copyright 2004 by Well House Consultants

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut