CatalystX::CMS::File - template file class

 use CatalystX::CMS::File;

 # longhand
 my $file = CatalystX::CMS::File->new( $path_to_file );
 $file->fetch if $page->size;
 $file->content('hello world');
 $file->title('super foo');
 $file->write;
 $file->commit or die $file->errstr;

 # shorthand
 my $file = CatalystX::CMS::File->new(
                        path    => $path_to_file,
                        title   => 'super foo',
                        content => 'hello world',
                        );
 eval { $file->save  } or die $file->errstr;
 print "$file was saved\n";

 <code class="tt">

package CatalystX::CMS::File;
use strict;
use warnings;
use base qw(
    SVN::Class::File
    Path::Class::File::Lockable
    Class::Accessor::Fast
);
use MRO::Compat;
use mro 'c3';
use Carp;
use Data::Dump qw( dump );

our $VERSION = '0.010';

__PACKAGE__->mk_accessors(qw( attrs content ext has_unsaved_changes ));

sub new {
    my $class = shift;
    my @param = @_;
    my ( $self, %arg );

    if ( !@param ) {
        croak "path required";
    }
    elsif ( @param == 1 ) {
        $self = $class->next::method(@param);
    }
    elsif ( @param % 2 ) {
        croak "new() requires either a path or a hash of key/value pairs";
    }
    elsif ( @param == 2 && $param[0] ne 'path' ) {
        $self = $class->next::method(@param);
    }
    else {
        %arg = @param;
        my $path = delete $arg{path} or croak "path required";
        $self = $class->next::method($path);
    }

    # add other attributes
    $self->{$_} = $arg{$_} for keys %arg;

    $self->{attrs} ||= {};

    # path cleanup
    $self->{ext} ||= '.tt';

    # re-create the object with extension
    my $ext = $self->{ext};
    unless ( $self =~ m/$ext$/ ) {
        $self = $self->new( $self . $self->{ext} );
    }

    #carp dump $self;

    return $self;
}

sub read {
    my $self = shift;
    croak("invalid path: $self") unless ( -f $self && -s $self );

    # TODO does ->slurp correctly handle utf8?
    $self->_parse_page( scalar $self->slurp );

    #$self->debug(1);

    # cache whether we have local mods
    my $committed = $self->committed;
    my $diff      = $self->diff;
    chomp( my $outstr = $self->outstr );

    #warn "committed = $committed\ndiff = $diff\noutstr = $outstr\n";

    if ( $committed && $diff && length $outstr ) {
        $self->has_unsaved_changes(1);
    }

    #$self->debug(0);

    return $self;
}

sub committed {
    my $self = shift;
    my $stat = $self->status;

    #warn "status = $stat";
    #warn "error  = " . $self->errstr;

    if ( $stat == 0 && grep {m/is not a working copy/} @{ $self->stderr } ) {

        #warn "committed == 0";
        return 0;
    }
    elsif ($stat) {

        # some status means svn knows about it or its parent dir.
        return 1;
    }
    elsif ( $stat == 0
        && !$self->error )
    {
        return 1;
    }

    return 0;
}

sub _parse_page {
    my ( $self, $buf ) = @_;

    # example:
    #
    #  [% # CMS
    #       cmspage.attrs.title = 'foo'
    #  %]
    #
    #   this is a page.
    #

    $self->_escape( \$buf );

    my ( $attrs, $content )
        = ( $buf =~ m/^\s*\[\%\s+\#\s*CMS\s+(.+?)\%\]\s*(.*)$/s );
    if ( $attrs && $content ) {
        my $depth = 100;
        my $count = 0;
        while ( $attrs =~ m/\bcmspage\.attrs\.(\w+)\s*=\s*(['"])(.+?)\2/sg ) {

            last if $count++ > $depth;

            my $key = $1;
            my $val = $3;

            # reserved words
            next if $key eq 'attrs';
            next if $key eq 'content';
            next if $key eq 'page';

            $self->{attrs}->{$key} = $val;
        }

        $self->content($content);
    }
    else {
        $self->content($buf);
    }
    return $self;
}

sub write {
    my $self = shift;
    my $force = shift || 0;

    if ( $self->locked && !$force ) {
        croak "write failed. $self is locked";
    }

    my $fh = $self->openw();

    # make sure we have at least one newline at end of file.
    my $content = $self->content || '';
    chomp $content;
    $content .= "\n";
    $self->_unescape( \$content );

    print {$fh} join( "\n", $self->_ttify_attrs, $content )
        or croak "write failed for $self: $!";
    $fh->close;

    return -s $self;
}

my $COMMENT      = 'CXCMS COMMENT: DO NOT REMOVE';
my @special_tags = qw( textarea );

sub _escape {
    my ( $self, $buf_ref ) = @_;

    for my $tag (@special_tags) {
        if ( $$buf_ref =~ m!</?$tag!i ) {
            $$buf_ref =~ s,<(/?${tag}.*?)>,<!-- $COMMENT $1 -->,sgi;
        }
    }
}

sub _unescape {
    my ( $self, $buf_ref ) = @_;

    if ( $$buf_ref =~ m!$COMMENT!i ) {
        $$buf_ref =~ s,<!-- $COMMENT (.+?) -->,<$1>,sgi;
    }
}

sub create {
    my $self = shift;
    my $user = shift or croak "user required";

    # create any required parent directories
    $self->dir->mkpath();

    if ( $self->locked or -s $self ) {
        croak "cannot create $self : locked or already exists";
    }

    $self->lock($user);
    $self->attrs->{owner} = $user;
    $self->content('[ this is a new page ]');
    return $self->write(1);
}

sub update {
    my $self = shift;
    if ( !-s $self ) {
        croak "cannot update an empty file";
    }
    $self->write(@_);
}

sub _ttify_attrs {
    my $self = shift;

    # make a TT-hash out of a Perl hash
    my $attrs = $self->attrs;
    my $buf   = "[% # CMS\n\n";
    for my $key ( sort keys %$attrs ) {
        $buf .= "    cmspage.attrs.$key = '" . qq($attrs->{$key}) . "';\n";
    }
    return $buf . "\n%]";
}

sub save {
    my $self       = shift;
    my $message    = shift || '[no log message]';
    my $leave_lock = shift || 0;
    my $username   = shift;

    # pass force flag to write() since we want lock
    # to persist till we've committed.

    $self->write(1) or croak "$self failed to write(): $!";

    # might be that the parent dir hasn't been added yet
    # so will get err rather than status.
    # track what level we need to commit at.
    my @to_add;

    my $dir = $self->dir;
    $dir->debug( $self->debug );

    my $self_status = $self->status;
    my $dir_status  = $dir->status;

    if ( $self->debug ) {
        warn "self = $self  status = $self_status";
        warn "dir = $dir  status = $dir_status";
    }

    # walk up the tree
    while (
        $dir_status eq '0'
        && ( $dir->errstr
            || grep {/is not a working copy/} @{ $dir->stderr } )
        )
    {

        $self->debug and warn "no status for $dir";
        unshift( @to_add, $dir );
        $dir        = $dir->parent;
        $dir_status = $dir->status;
        $self->debug and warn "dir $dir status = $dir_status";

        # avoid infinite loops
        if ( $dir eq '/' ) {
            croak "infinite loop looking up svn workdir tree for $self";
        }
    }

    # found one that svn knows about
    if ( $dir_status eq '?' or $dir_status eq 'A' ) {
        unshift( @to_add, $dir );
    }

    $self->debug and warn "to_add: " . dump \@to_add;

    # we 'add' each dir non-recursively
    # so that we do not add unaffected files (like lock files) by mistake.
    for my $d (@to_add) {
        $d->add( ['-N'] ) unless $d->status eq 'A';
        my @opts = '-N';
        if ($username) {
            push( @opts, "--username $username" );
        }
        $d->commit( "new directory", \@opts )
            or croak "add directory $d failed: " . $d->errstr;
    }

    # now check the stat of the file itself
    my $stat = $self->status;
    if ( $stat && $stat eq '?' ) {
        $self->add;
    }

    my $ret;

    # is file modified at all?
    if ( $self->modified ) {
        $ret = $self->commit($message);
    }
    else {

        # no attempt made to commit unmodified file
        $ret = -1;
    }

    unless ($leave_lock) {
        $self->unlock or croak "can't unlock $self: $!";
    }
    return $ret;
}

sub escape_tt {
    my $self    = shift;
    my $content = $self->content;

    $content =~ s/\[\%/<code class="tt">\[\%/g;
    $content =~ s/\%\]/\%\]<\/code>/g;

    return $content;
}

# this isn't currently used but could be.
#sub as_chunks {
#    my $self = shift;
#    my $escape = shift || 0;
#
#    # NOTE the regex keeps the surrounding whitespace WITH the PROCESS
#    # line so that it is preserved in the web interaction.
#    my @chunks = split( m!(\s*\[\%\ +PROCESS tt/share/\S+\ +\%\]\s*)!s,
#        $self->content );
#
#    # turn into array of hashrefs
#    my @hashes;
#
#    #carp "raw chunks: " . dump \@chunks;
#
#    for my $chunk (@chunks) {
#        my $h = { content => $chunk };
#
#        # editable text
#        unless ( $chunk =~ m/^\s*\[\%\s+PROCESS/ ) {
#            $h->{editable} = 1;
#
#            # wrap TT instructions in <pre> tags so they show verbatim
#            if ($escape) {
#                $h->{content} =~ s,\[\%,<pre class="tt">\[\%,g;
#                $h->{content} =~ s,\%\],\%\]</pre>,g;
#            }
#
#        }
#
#        # shared text -- render it as TT would but just that chunk.
#        else {
#            $h->{editable} = 0;
#        }
#
#        push( @hashes, $h );
#    }
#
#    return \@hashes;
#}
#
#=head2 save_chunk( I<chunk_id>, I<new_text>, I<message> )
#
#I<chunk_id> is element of the array returned by as_chunks().
#
#I<new_text> is the text to be saved at that element.
#
#Calls save() with I<message>. Returns save() return value.
#
#=cut
#
#sub save_chunk {
#    my $self    = shift;
#    my $id      = shift || 0;
#    my $text    = shift || '';
#    my $message = shift or croak "need save message";
#
#    my $chunks = $self->as_chunks;    # NO escape
#
#    $chunks->[$id]->{content} = $text;
#
#    carp dump $chunks;
#
#    $self->content( join( '', map { $_->{content} } @$chunks ) );
#
#    return $self->save( $message, 1 );
#}

1;

__END__