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