File Coverage

blib/lib/SVN/Dumpfile/Node.pm

Criterion	Covered	Total	%
statement	172	180	95.5
branch	41	72	56.9
condition	28	73	38.3
subroutine	38	38	100.0
pod	24	24	100.0
total	303	387	78.2

################################################################################
# Copyright (c) 2008 Martin Scharrer
# This is open source software under the GPL v3 or later.
#
# $Id: Node.pm 103 2008-10-14 21:11:21Z martin $
################################################################################
package SVN::Dumpfile::Node;
use strict;
use warnings;
use 5.008001;
use SVN::Dumpfile::Node::Headers;
use SVN::Dumpfile::Node::Properties;
use SVN::Dumpfile::Node::Content;
use Digest::MD5 qw(md5_hex);
use Carp;
use Date::Parse;
use Readonly;
Readonly my $NL => chr(10);

our $VERSION = do { '$Rev: 103 $' =~ /\$Rev: (\d+) \$/; '0.13' . ".$1" };

sub new {
    my $arg = shift;
    my $class = ref $arg || $arg;

    my %hasharg;
    my $hargref = \%hasharg;

    if ( @_ == 1 && ref( $_[0] ) eq 'HASH' ) {
        $hargref = shift;
    }
    elsif ( @_ % 2 == 0 ) {
        %hasharg = @_;
        $hargref = \%hasharg;
    }
    elsif ( @_ == 1 && !defined $_[0] ) {

        # Ignore single undef value
    }
    else {
        carp
            "${class}::new() awaits a hashref or even array with key/value pairs."
            . "Ignoring all arguments.";
    }

    my $self = bless {
        headers => SVN::Dumpfile::Node::Headers->new( $hargref->{'headers'} ),
        properties =>
            SVN::Dumpfile::Node::Properties->new( $hargref->{'properties'} ),
        contents => SVN::Dumpfile::Node::Content->new( $hargref->{'content'} ),
        changed => scalar keys %$hargref,
    }, $class;
    return $self;
}

sub newrev {
    my $arg = shift;
    my $class = ref $arg || $arg;
    my $r;

    if ( @_ == 1 && ref( $_[0] ) eq 'HASH' ) {
        $r = shift;
    }
    elsif ( @_ % 2 == 0 ) {
        $r = {@_};
    }
    elsif ( @_ == 1 && !defined $_[0] ) {

        # Ignore single undef value
    }
    else {
        carp
            "${class}::newrev() awaits a hashref or even array with key/value pairs."
            . "Ignoring all arguments.";
    }

    my $strdate;
    if (   !exists $r->{date}
        || $r->{date} =~ /^\d+$/
        || ( $strdate = str2time( $r->{date} ) ) )
    {
        my $time = $strdate || $r->{date} || time;
        my ( $sec, $min, $hour, $mday, $mon, $year ) = gmtime($time);

        # '2006-05-10T13:31:40.486172Z'
        $r->{date} = sprintf(
            "%04d-%02d-%02dT%02d:%02d:%02d.%06dZ",
            $year + 1900,
            $mon + 1, $mday, $hour, $min, $sec, 0
        );
    }
    elsif ( $r->{date} !~ /^\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}\.\d{6}Z$/ ) {
        carp "Wrong format for new revision node given. Import of resulting "
            . "dumpfile might break.";
    }

    return $class->new(
        headers => {
            'Revision-number' => $r->{number} || 0,
            'Prop-content-length' => 0,
            'Content-length'      => 0,
        },
        properties => {
            'svn:author' => $r->{author} || $ENV{USER} || '(unknown)',
            'svn:date' => $r->{date},
            (exists $r->{'log'}) ? ('svn:log' => $r->{'log'}) : ()
        }
    );

}

sub content : lvalue {
    my $self = shift;
    $self->{contents}->value(@_);
}

sub contents {
    my $self = shift;
    return $self->{contents};
}

sub has_contents {
    my $self = shift;
    return unless exists $self->{contents};
    return $self->{contents}->exists;
}

sub header : lvalue {
    my ( $self, $h, $value ) = @_;

    $self->{headers}->{$h} = $value
        if defined $value;
    $self->{headers}->{$h};
}

sub headers {
    my $self = shift;
    return $self->{headers};
}

sub has_header {
    my $self = shift;
    my $header = shift;
    return unless exists $self->{headers};
    return exists $self->{headers}->{$header};
}

sub has_headers {
    my $self = shift;
    return if not exists $self->{headers};
    return scalar keys %{ $self->{headers} };
}

sub property : lvalue {
    my ( $self, $prop, $value ) = @_;
    if ( @_ == 1 ) {
        return $self->{properties}->{property};
    }
    $self->{properties}->{property}->{$prop} = $value
        if defined $value;
    $self->{properties}->{property}->{$prop};
}

sub has_property {
    my $self = shift;
    my $prop = shift;
    return
        unless exists $self->{properties}
            and exists $self->{properties}->{property};
    return exists $self->{properties}->{property}->{$prop};
}

sub properties {
    my $self = shift;
    return $self->{properties};
}

sub has_properties {
    my $self = shift;
    return
        unless exists $self->{properties}
            and exists $self->{properties}->{property};
    return scalar keys %{ $self->{properties}->{property} };
}

sub changed {
    my $self = shift;
    $self->{changed} = 1;
    return;
}

sub has_changed {
    my $self = shift;
    return $self->{changed};
}

sub is_rev {
    my $self = shift;
    return exists $self->{headers}{'Revision-number'};
}

sub revnum : lvalue {
    my ( $self, $value ) = shift;
    $self->{headers}{'Revision-number'} = $value
        if defined $value;

    $self->{headers}{'Revision-number'};
}

sub read {
    my $self = shift;
    my $fh   = shift;    # Filehandle to read
    my $line;

    return unless defined $fh and eval { $fh->isa('IO::Handle') };

    my $header = $self->{'headers'};

    my $irs = IO::Handle->input_record_separator($NL);

    $self->{headers}->read($fh);
    return if $fh->eof;

    # Get properties when they exist (but then they can be empty also!)
    $self->{properties}->read( $fh, $header->{'Prop-content-length'} )
        if exists $header->{'Prop-content-length'};

    # Get content
    $self->{contents}->read( $fh, $header->{'Text-content-length'} )
        if exists $header->{'Text-content-length'};

    # Save delimiter blank lines to be able to restore the input file exact
    $self->{delim} = "";
    my $c;
    while ( $c = $fh->getc and $c eq $NL ) {
        $self->{delim} .= $c;
    }
    $fh->ungetc( ord $c ) if defined $c;

    IO::Handle->input_record_separator($irs);
    return 1;
}

#################
## Write node entry to filehandle

sub write {
    my $self = shift;    # Hash (as reference) with node to be written
    my $fh   = shift;    # Filehandle to write to
    my $ret  = 1;

    croak "Given argument is not a valid file handle."
        unless defined $fh;

    my $header = $self->{headers};

    return unless ( $header->number );    # skip if there is no header

    $self->recalc_headers if $self->{changed};

    $ret &&= $self->{headers}->write($fh);

    # Properties
    $ret &&= $self->{properties}->write($fh)
        if ( exists $header->{'Prop-content-length'}
        and $header->{'Prop-content-length'} > 0 );

    # Content
    $ret &&= $self->{contents}->write($fh)
        if ( exists $header->{'Text-content-length'}
        and $header->{'Text-content-length'} > 0 );

    $ret &&= $fh->print( exists $self->{delim} ? $self->{delim} : $NL );
    return $ret;
}

sub as_string {
    my $self = shift;
    return '' unless ( $self->has_headers );    # skip if there are no header
    $self->recalc_headers if $self->{changed};

    return ''
        . $self->{headers}->as_string
        . $NL
        . $self->{properties}->as_string
        . $self->{contents}->as_string
        . ( $self->{delim} || $NL );
}

sub recalc_headers {
    my $self = shift;

    $self->recalc_textcontent_header;
    $self->recalc_prop_header;

    $self->{changed} = 0;
    return;
}

#################
## recalc_content_header - Recalculate 'Content-length' header
#####
# Depends on correct values in other headers.
# Will be called by other recalc-functions.

sub recalc_content_header {
    my $self   = shift;
    my $header = $self->{headers};
    no warnings 'uninitialized';

    my $header_existed = exists $header->{'Content-length'};

    $header->{'Content-length'}
        = $header->{'Text-content-length'} + $header->{'Prop-content-length'};

    if ( $header->{'Content-length'} == 0 && !$header_existed ) {
        delete $header->{'Content-length'};
    }
    return;
}

#################
## recalc_textcontent_header - Recalculate 'Text-content'* and dependend headers
#####

sub recalc_textcontent_header {
    use bytes;
    no warnings 'uninitialized';
    my $self   = shift;
    my $header = $self->{headers};

    my $oldlength      = $header->{'Text-content-length'};
    my $header_existed = exists $header->{'Text-content-length'};

    my $length
        = defined $self->{'contents'}
        ? $self->{'contents'}->length
        : 0;

    if ( !$header_existed && $length == 0 ) {
        delete $header->{'Text-content-length'};
        delete $header->{'Text-content-md5'};
    }
    else {
        $header->{'Text-content-length'} = $length;
        $header->{'Text-content-md5'}    = md5_hex( ${ $self->{'contents'} } );
    }

    $self->recalc_content_header
        if ( $oldlength != $header->{'Text-content-length'} );
    return;
}

#################
## recalc_prop_header - Recalculate 'Prop-content-length' and dependend headers
#####

sub recalc_prop_header {
    use bytes;
    my $self   = shift;
    my $header = $self->{'headers'};
    my $prop   = $self->{'properties'};

    # Don't remove or create header unless necessary
    my $header_existed = exists $header->{'Prop-content-length'};

    # Correct properties length:
    $header->{'Prop-content-length'} = $prop->length;

    if ( !$header_existed && $header->{'Prop-content-length'} eq 10 ) {
        delete $header->{'Prop-content-length'};
    }

    $self->recalc_content_header;
    return;
}

1;
__END__