File Coverage

blib/lib/Wizard/SaveAble.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

# -*- perl -*-
#
#   Wizard - A Perl package for implementing system administration
#            applications in the style of Windows wizards.
#
#
#   This module is
#
#           Copyright (C) 1999     Jochen Wiedmann
#                                  Am Eisteich 9
#                                  72555 Metzingen
#                                  Germany
#
#                                  Email: [e-mail]
#                                  Phone: [phone]
#
#                          and     Amarendran R. Subramanian
#                                  Grundstr. 32
#                                  72810 Gomaringen
#                                  Germany
#
#                                  Email: [e-mail]
#                                  Phone: [phone]
#
#   All Rights Reserved.
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file.
#
#   $Id$
#

use strict;

use Symbol ();
use Data::Dumper ();
use IO::AtomicFile ();
use File::Basename ();
use File::Path ();

package Wizard::SaveAble;

$Wizard::SaveAble::VERSION = '0.01';


=pod

=head1 NAME

    Wizard::SaveAble - A package for automatically saved objects.


=head1 SYNOPSIS

    # Tell a SaveAble object that it's modified
    $obj->Modified(1);

    # Tell the SaveAble object to store itself back to disk
    $obj->Store();


=head1 DESCRIPTION

An object of the class Wizard::SaveAble is something that knows whether
it has to be saved or not. To that end it offers methods like I
and I.


=head1 CLASS INTERFACE

All methods are throwing a Perl exception in case of errors.


=head2 Constructors

  # Create an empty SaveAble object and associate a file name to it.
  my $obj = Wizard::SaveAble->new('file' => $file);

  # Load a SaveAble object from a file.
  my $obj = Wizard::SaveAble->new($file);

  # Same thing, but creating an empty object if $file doesn't exist
  my $obj = Wizard::SaveAble->new('file' => $file, 'load' => 1);

(Class method) There are two possible constructors for the
I class: The first is creating an empty object, you
typically use a subclass of I here. The most important
attribute is the I name where the object should later be stored.

The other constructor is loading an already existing object from a file.
The object is automatically blessed into the same class again, typically
a subclass of Wizard::SaveAble.

=cut

sub _load {
    my $proto = shift; my $file = shift;
    my $self = do $file;
    die "Failed to load Wizard::SaveAble object from $file: $@" if $@;
    die "Error while loading $file: Object returned is not an instance"
	. " of Wizard::SaveAble: " . (defined($self) ? $self : "undef")
	    unless UNIVERSAL::isa($self, "Wizard::SaveAble");
    $self->Modified(0);
    $self->File($file);
    $self;
}

sub new {
    my $proto = shift;
    return $proto->_load(shift) if @_ == 1;
    my $self = { @_ };
    my $file = delete $self->{'file'} if (exists($self->{'file'}));
    if (exists($self->{'load'})  and  delete $self->{'load'}) {
	return $proto->_load($file) if $file and -f $file;
    }
    bless($self, (ref($proto) || $proto));
    $self->Modified(1);
    $self->File($file);
    $self->CreateMe($file);
    $self;
}

sub CreateMe {
    my $self = shift;
    $self->{'_wizard_saveable_createme'} = shift if @_;
    $self->{'_wizard_saveable_createme'};
}

=pod

=head2 Setting and Querying an objects status

  # Tell an object that it's modified
  $obj->Modified(1);
  # Query whether an object is modified
  $modified = $obj->Modified()

(Instance methods) The I method is used to determine whether an
object needs to be saved or not.

=cut

sub Modified {
    my $self = shift;
    if (@_) {
	if (shift) {
	    $self->{'_wizard_saveable_modified'} = 1;
	} else {
	    delete $self->{'_wizard_saveable_modified'};
	}
    }
    exists($self->{'_wizard_saveable_modified'});
}


=pod

=head2 Setting and Querying an objects file name

  # Set the objects associated file
  $obj->File($file);
  # Query the objects associated file
  $file = $obj->File();

(Instance methods) The I method is used to determine whether an
object needs to be saved or not.

=cut

sub File {
    my $self = shift;
    $self->{'_wizard_saveable_file'} = shift if @_;
    $self->{'_wizard_saveable_file'};
}


=pod

=head2 Storing an object to disk

  $obj->Store();

(Instance Method) The object is stored back to disk into the file that
was fixed within the constructor.

=cut

sub Store {
    my $self = shift;

    # Create a copy of the object to work with it.
    my $copy = { %$self };
    bless($copy, ref($self));

    return unless delete $copy->{'_wizard_saveable_modified'};

    delete $copy->{'_wizard_saveable_createme'};
    my $file = delete $copy->{'_wizard_saveable_file'};
    my $dir = File::Basename::dirname($file);
    die "Failed to create directory $dir: $!"
	unless -d $dir  ||  File::Path::mkpath([$dir], 0, 0644);

    my $dump = Data::Dumper->new([$copy], ['obj']);
    $dump->Indent(1);
    my $fh = IO::AtomicFile->open($file, "w")
	or die "Failed to create file $file: $!";
    if (!$fh->print("my ", $dump->Dump())  ||  !$fh->close()) {
	my $msg = $!;
	$fh->delete();
	die "Failed to write file $file: $msg";
    }
    $self->Modified(0);
}


=pod

=head1 AUTHORS AND COPYRIGHT

This module is

  Copyright (C) 1999     Jochen Wiedmann
                         Am Eisteich 9
                         72555 Metzingen
                         Germany

                         Email: [e-mail]
                         Phone: [phone]

                 and     Amarendran R. Subramanian
                         Grundstr. 32
                         72810 Gomaringen
                         Germany

                         Email: [e-mail]
                         Phone: [phone]

All Rights Reserved.

You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl README file.


=head1 SEE ALSO

L, L

=cut