lib/MooseX/Storage/Basic.pm

   1 package MooseX::Storage::Basic;
   2 use Moose::Role;
   3
   4 use MooseX::Storage::Engine;
   5 use String::RewritePrefix;
   6
   7 our $VERSION   = '0.32';
   8 our $AUTHORITY = 'cpan:STEVAN';
   9
  10 sub pack {
  11     my ( $self, %args ) = @_;
  12     my $e = $self->_storage_get_engine_class(%args)->new( object => $self );
  13     $e->collapse_object(%args);
  14 }
  15
  16 sub unpack {
  17     my ($class, $data, %args) = @_;
  18     my $e = $class->_storage_get_engine_class(%args)->new(class => $class);
  19
  20     $class->_storage_construct_instance(
  21         $e->expand_object($data, %args),
  22         \%args
  23     );
  24 }
  25
  26 sub _storage_get_engine_class {
  27     my ($self, %args) = @_;
  28
  29     return 'MooseX::Storage::Engine'
  30         unless (
  31             exists $args{engine_traits}
  32          && ref($args{engine_traits}) eq 'ARRAY'
  33          && scalar(@{$args{engine_traits}})
  34     );
  35
  36     my @roles = String::RewritePrefix->rewrite(
  37         {
  38             '' => 'MooseX::Storage::Engine::Trait::',
  39             '+' => '',
  40         },
  41         @{$args{engine_traits}}
  42     );
  43
  44     Moose::Meta::Class->create_anon_class(
  45         superclasses => ['MooseX::Storage::Engine'],
  46         roles => [ @roles ],
  47         cache => 1,
  48     )->name;
  49 }
  50
  51 sub _storage_construct_instance {
  52     my ($class, $args, $opts) = @_;
  53     my %i = defined $opts->{'inject'} ? %{ $opts->{'inject'} } : ();
  54
  55     $class->new( %$args, %i );
  56 }
  57
  58 no Moose::Role;
  59
  60 1;
  61
  62 __END__
  63
  64 =pod
  65
  66 =head1 NAME
  67
  68 MooseX::Storage::Basic - The simplest level of serialization
  69
  70 =head1 SYNOPSIS
  71
  72   package Point;
  73   use Moose;
  74   use MooseX::Storage;
  75
  76   our $VERSION = '0.01';
  77
  78   with Storage;
  79
  80   has 'x' => (is => 'rw', isa => 'Int');
  81   has 'y' => (is => 'rw', isa => 'Int');
  82
  83   1;
  84
  85   my $p = Point->new(x => 10, y => 10);
  86
  87   ## methods to pack/unpack an
  88   ## object in perl data structures
  89
  90   # pack the class into a hash
  91   $p->pack(); # { __CLASS__ => 'Point-0.01', x => 10, y => 10 }
  92
  93   # unpack the hash into a class
  94   my $p2 = Point->unpack({ __CLASS__ => 'Point-0.01', x => 10, y => 10 });
  95
  96   # unpack the hash, with insertion of paramaters
  97   my $p3 = Point->unpack( $p->pack, inject => { x => 11 } );
  98
  99 =head1 DESCRIPTION
 100
 101 This is the most basic form of serialization. This is used by default
 102 but the exported C<Storage> function.
 103
 104 =head1 METHODS
 105
 106 =over 4
 107
 108 =item B<pack ([ disable_cycle_check => 1])>
 109
 110 Providing the C<disable_cycle_check> argument disables checks for any cyclical
 111 references. The current implementation for this check is rather naive, so if
 112 you know what you are doing, you can bypass this check.
 113
 114 This trait is applied on a perl-case basis. To set this flag for all objects
 115 that inherit from this role, see L<MooseX::Storage::Traits::DisableCycleDetection>.
 116
 117 =item B<unpack ($data [, insert => { key => val, ... } ] )>
 118
 119 Providing the C<insert> argument let's you supply additional arguments to
 120 the class' C<new> function, or override ones from the serialized data.
 121
 122 =back
 123
 124 =head2 Introspection
 125
 126 =over 4
 127
 128 =item B<meta>
 129
 130 =back
 131
 132 =head1 BUGS
 133
 134 All complex software has bugs lurking in it, and this module is no
 135 exception. If you find a bug please either email me, or add the bug
 136 to cpan-RT.
 137
 138 =head1 AUTHOR
 139
 140 Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
 141
 142 Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
 143
 144 =head1 COPYRIGHT AND LICENSE
 145
 146 Copyright 2007-2008 by Infinity Interactive, Inc.
 147
 148 L<http://www.iinteractive.com>
 149
 150 This library is free software; you can redistribute it and/or modify
 151 it under the same terms as Perl itself.
 152
 153 =cut