—# @(#)$Id: Schema.pm 431 2013-04-01 01:11:58Z pjf $
package
File::DataClass::Schema;
use
strict;
use
namespace::autoclean;
use
Moose;
use
Class::Null;
use
File::DataClass::IO;
use
File::Spec;
has
'cache'
=>
is
=>
'ro'
,
isa
=> Cache,
builder
=>
'_build_cache'
,
lazy
=> TRUE;
has
'cache_attributes'
=>
is
=>
'ro'
,
isa
=> HashRef,
default
=>
sub
{ {
driver
=>
q(FastMmap)
,
page_size
=> 131072,
num_pages
=> 89,
unlink_on_exit
=> TRUE, } };
has
'cache_class'
=>
is
=>
'ro'
,
isa
=> ClassName | DummyClass,
default
=>
q(File::DataClass::Cache)
;
has
'debug'
=>
is
=>
'ro'
,
isa
=> Bool,
default
=> FALSE;
has
'lock'
=>
is
=>
'ro'
,
isa
=> Lock,
default
=>
sub
{ Class::Null->new },
lazy
=> TRUE;
has
'log'
=>
is
=>
'ro'
,
isa
=> Object,
default
=>
sub
{ Class::Null->new },
lazy
=> TRUE;
has
'path'
=>
is
=>
'rw'
,
isa
=> Path,
coerce
=> TRUE;
has
'perms'
=>
is
=>
'rw'
,
isa
=> Num,
default
=> PERMS;
has
'result_source_attributes'
=>
is
=>
'ro'
,
isa
=> HashRef,
default
=>
sub
{ {} };
has
'result_source_class'
=>
is
=>
'ro'
,
isa
=> ClassName,
default
=>
q(File::DataClass::ResultSource)
;
has
'source_registrations'
=>
is
=>
'ro'
,
isa
=> HashRef[Object],
builder
=>
'_build_source_registrations'
,
lazy
=> TRUE;
has
'storage'
=>
is
=>
'rw'
,
isa
=> Object,
builder
=>
'_build_storage'
,
lazy
=> TRUE;
has
'storage_attributes'
=>
is
=>
'ro'
,
isa
=> HashRef,
default
=>
sub
{ {} };
has
'storage_base'
=>
is
=>
'ro'
,
isa
=> ClassName,
default
=>
q(File::DataClass::Storage)
;
has
'storage_class'
=>
is
=>
'rw'
,
isa
=> Str,
default
=>
q(XML::Simple)
;
has
'tempdir'
=>
is
=>
'ro'
,
isa
=> Directory,
coerce
=> TRUE,
default
=> File::Spec->tmpdir;
around
'BUILDARGS'
=>
sub
{
my
(
$next
,
$class
,
@args
) =
@_
;
my
$attr
=
$class
->
$next
(
@args
);
my
$builder
=
delete
$attr
->{builder} or
return
$attr
;
my
$config
=
$builder
->can(
q(config)
) ?
$builder
->config : {};
merge_attributes
$attr
,
$builder
, [
qw(debug lock log tempdir)
];
merge_attributes
$attr
,
$config
, [
qw(tempdir)
];
return
$attr
;
};
sub
dump
{
my
(
$self
,
$args
) =
@_
; blessed
$self
or
$self
=
$self
->_constructor;
my
$path
=
$args
->{path} ||
$self
->path;
blessed
$path
or
$path
= io(
$path
);
return
$self
->storage->
dump
(
$path
,
$args
->{data} || {} );
}
sub
extensions {
return
EXTENSIONS;
}
sub
load {
my
(
$self
,
@paths
) =
@_
; blessed
$self
or
$self
=
$self
->_constructor;
$paths
[ 0 ] or
$paths
[ 0 ] =
$self
->path;
@paths
=
map
{ blessed
$_
?
$_
: io(
$_
) }
@paths
;
return
$self
->storage->load(
@paths
) || {};
}
sub
resultset {
my
(
$self
,
$moniker
) =
@_
;
return
$self
->source(
$moniker
)->resultset;
}
sub
source {
my
(
$self
,
$moniker
) =
@_
;
$moniker
or throw
'Result source not specified'
;
my
$source
=
$self
->source_registrations->{
$moniker
}
or throw
error
=>
'Result source [_1] unknown'
,
args
=> [
$moniker
];
return
$source
;
}
sub
sources {
return
keys
%{
shift
->source_registrations };
}
sub
translate {
my
(
$self
,
$args
) =
@_
;
my
$class
= blessed
$self
||
$self
;
my
$from_class
=
$args
->{from_class} ||
q(Any)
;
my
$to_class
=
$args
->{to_class } ||
q(Any)
;
my
$attrs
= {
path
=>
$args
->{from},
storage_class
=>
$from_class
};
my
$data
=
$class
->new(
$attrs
)->load;
$attrs
= {
path
=>
$args
->{to},
storage_class
=>
$to_class
};
$class
->new(
$attrs
)->
dump
( {
data
=>
$data
} );
return
;
}
# Private methods
sub
_build_cache {
my
$self
=
shift
; (
my
$ns
=
lc
__PACKAGE__) =~ s{ :: }{-}gmx;
my
$cache
;
my
$attrs
= {
cache_attributes
=> { %{
$self
->cache_attributes } },
builder
=>
$self
};
$ns
=
$attrs
->{cache_attributes}->{namespace} ||=
$ns
;
$cache
=
$self
->F_DC_Cache and
exists
$cache
->{
$ns
}
and
return
$cache
->{
$ns
};
$self
->cache_class eq
q(none)
and
return
Class::Null->new;
$attrs
->{cache_attributes}->{root_dir} ||= NUL.
$self
->tempdir;
return
$self
->F_DC_Cache->{
$ns
} =
$self
->cache_class->new(
$attrs
);
}
sub
_build_source_registrations {
my
$self
=
shift
;
my
$sources
= {};
for
my
$moniker
(
keys
%{
$self
->result_source_attributes }) {
my
$attrs
= { %{
$self
->result_source_attributes->{
$moniker
} } };
my
$class
=
delete
$attrs
->{result_source_class}
||
$self
->result_source_class;
$attrs
->{name} =
$moniker
;
$attrs
->{schema} =
$self
;
$sources
->{
$moniker
} =
$class
->new(
$attrs
);
}
return
$sources
;
}
sub
_build_storage {
my
$self
=
shift
;
my
$class
=
$self
->storage_class;
if
(
q(+)
eq
substr
$class
, 0, 1) {
$class
=
substr
$class
, 1 }
else
{
$class
=
$self
->storage_base.
q(::)
.
$class
}
ensure_class_loaded
$class
;
return
$class
->new( { %{
$self
->storage_attributes },
schema
=>
$self
} );
}
sub
_constructor {
my
$class
=
shift
;
my
$attr
= {
cache_class
=>
q(none)
,
storage_class
=>
q(Any)
};
return
$class
->new(
$attr
);
}
__PACKAGE__->meta->make_immutable;
no
Moose;
1;
__END__
=pod
=head1 Name
File::DataClass::Schema - Base class for schema definitions
=head1 Version
0.15.$Revision: 431 $
=head1 Synopsis
use File::DataClass::Schema;
$schema = File::DataClass::Schema->new
( path => [ qw(path to a file) ],
result_source_attributes => { source_name => {}, },
tempdir => [ qw(path to a directory) ] );
$schema->source( q(source_name) )->attributes( [ qw(list of attr names) ] );
$rs = $schema->resultset( q(source_name) );
$result = $rs->find( { name => q(id of field element to find) } );
$result->$attr_name( $some_new_value );
$result->update;
@result = $rs->search( { 'attr name' => q(some value) } );
=head1 Description
Base class for schema definitions. Each element in a data file
requires a result source to define it's attributes
=head1 Configuration and Environment
Registers all result sources defined by the result source attributes
Creates a new instance of the storage class which defaults to
L<File::DataClass::Storage::XML::Simple>
Defines these attributes
=over 3
=item C<cache>
Instantiates and returns the L<Cache|File::DataClass/Cache> class
attribute. Built on demand
=item C<cache_attributes>
Passed to the L<Cache::Cache> constructor
=item C<debug>
Writes debug information to the log object if set to true
=item C<exception_class>
A classname that is expected to have a class method C<throw>. Defaults to
L<File::DataClass::Exception> and is of type C<File::DataClass::Exception>
=item C<builder>
An optional object that provides these methods; C<debug>,
C<exception_class>, C<lock>, C<log>, and C<tempdir>. Their values are
or'ed with values in the attributes hash before being passed to the
constructor
=item C<lock>
Defaults to L<Class::Null>. Can be set via the C<builder>
attribute. Built on demand
=item C<log>
Log object. Typically an instance of L<Log::Handler>
=item C<path>
Path to the file. This is a L<File::DataClass::IO> object that can be
coerced from either a string or an array ref
=item C<perms>
Permissions to set on the file if it is created. Defaults to
L<PERMS|File::DataClass::Constants/PERMS>
=item C<result_source_attributes>
A hash ref of result sources. See L<File::DataClass::ResultSource>
=item C<result_source_class>
The class name used to create result sources when the source registration
attribute is instantiated. Acts as a schema wide default of not overridden
in the C<result_source_attributes>
=item C<source_registrations>
A hash ref or registered result sources, i.e. the keys of the
C<result_source_attributes> hash
=item C<storage>
An instance of a subclass of L<File::DataClass::Storage>
=item C<storage_attributes>
Attributes passed to the storage object's constructor
=item C<storage_base>
If the storage class is only a partial classname then this attribute is
prepended to it
=item C<storage_class>
The name of the storage class to instantiate
=item C<tempdir>
Temporary directory used to store the cache and lock objects disk
representation
=back
=head1 Subroutines/Methods
=head2 dump
$schema->dump( { path => $to_file, data => $data_hash } );
Dumps the data structure to a file. Path defaults to the one specified in
the schema definition. Returns the data that was written to the file if
successful
=head2 extensions
\%extension_map = $self->extensions;
Returns a hash ref that maps filename extensions (keys) onto storage
subclasses (values)
=head2 load
$data_hash = $schema->load( @paths );
Loads and returns the merged data structure from the named
files. Paths defaults to the one specified in the schema
definition. Data will be read from cache if available and not stale
=head2 resultset
$rs = $schema->resultset( $source_name );
Returns a resultset object which by default is an instance of
L<File::DataClass::Resultset>
=head2 source
$source = $schema->source( $source_name );
Returns a result source object which by default is an instance of
L<File::DataClass::ResultSource>
=head2 sources
@sources = $schema->sources;
Returns a list of all registered result source names
=head2 translate
$schema->translate( $args );
Reads a file in one format and writes it back out in another format
=head1 Diagnostics
Setting the C<debug> attribute to true will cause the log object's
debug method to be called with useful information
=head1 Dependencies
=over 3
=item L<namespace::autoclean>
=item L<Class::Null>
=item L<File::DataClass>
=item L<File::DataClass::Cache>
=item L<File::DataClass::Constants>
=item L<File::DataClass::Exception>
=item L<File::DataClass::Functions>
=item L<File::DataClass::ResultSource>
=item L<File::DataClass::Storage>
=item L<IPC::SRLock>
=item L<Moose>
=back
=head1 Incompatibilities
There are no known incompatibilities in this module
=head1 Bugs and Limitations
There are no known bugs in this module.
Please report problems to the address below.
Patches are welcome
=head1 Acknowledgements
Larry Wall - For the Perl programming language
=head1 Author
Peter Flanigan, C<< <Support at RoxSoft.co.uk> >>
=head1 License and Copyright
Copyright (c) 2013 Peter Flanigan. All rights reserved
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>
This program is distributed in the hope that it will be useful,
but WITHOUT WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
=cut
# Local Variables:
# mode: perl
# tab-width: 3
# End: