File Coverage

blib/lib/CPAN/Changes.pm

Criterion	Covered	Total	%
statement	123	128	96.0
branch	55	60	91.6
condition	12	20	60.0
subroutine	17	18	94.4
pod	10	10	100.0
total	217	236	91.9

package CPAN::Changes;

use strict;
use warnings;

use CPAN::Changes::Release;
use Scalar::Util ();
use version      ();
use Encode qw(decode FB_CROAK LEAVE_SRC);

our $VERSION = '0.400001';

# From DateTime::Format::W3CDTF
our $W3CDTF_REGEX = qr{(\d\d\d\d) # Year
                 (?:-(\d\d) # -Month
                 (?:-(\d\d) # -Day
                 (?:[T\s]
                   (\d\d):(\d\d) # Hour:Minute
                   (?:
                     :(\d\d)     # :Second
                     (\.\d+)?    # .Fractional_Second
                   )?
                   ( Z          # UTC
                   | [+-]\d\d:\d\d    # Hour:Minute TZ offset
                     (?::\d\d)?       # :Second TZ offset
                 )?)?)?)?}x;

my @m = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
my %months = map { $m[ $_ ] => $_ + 1 } 0 .. 11;

our $UNKNOWN_VALS = join( '|', (
    'Unknown Release Date', 'Unknown', 'Not Released', 'Development Release',
    'Development', 'Developer Release',
) );

sub new {
    my $class = shift;
    return bless {
        preamble => '',
        releases => {},
        months   => \%months,
        @_,
    }, $class;
}

sub load {
    my ( $class, $file, @args ) = @_;

    open( my $fh, '<:raw', $file ) or die $!;

    my $content = do { local $/; <$fh> };

    close $fh;

    # if it's valid UTF-8, decode that.  otherwise, assume latin 1 and leave it.
    eval { $content = decode('UTF-8', $content, FB_CROAK | LEAVE_SRC) };

    return $class->load_string( $content, @args );
}

sub load_string {
    my ( $class, $string, @args ) = @_;

    my $changes  = $class->new( @args );
    my $preamble = '';
    my ( @releases, $ingroup, $indent );

    $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/gs;
    my @lines = split( "\n", $string );

    my $version_line_re
        = $changes->{ next_token }
        ? qr/^(?:$version::LAX|$changes->{next_token})/
        : qr/^$version::LAX/;

    $preamble .= shift( @lines ) . "\n" while @lines && $lines[ 0 ] !~ $version_line_re;

    for my $l ( @lines ) {

        # Version & Date
        if ( $l =~ $version_line_re ) {
            my ( $v, $n ) = split m{\s[\W\s]*}, $l, 2;
            my $match = '';
            my $d;

            # munge date formats, save the remainder as note
            if ( $n ) {
                # unknown dates
                if ( $n =~ m{^($UNKNOWN_VALS)}i ) {
                    $d     = $1;
                    $match = $d;
                }
                # handle localtime-like timestamps
                elsif ( $n
                    =~ m{^(\D{3}\s+(\D{3})\s+(\d{1,2})\s+([\d:]+)?\D*(\d{4}))} )
                {
                    $match = $1;
                    if ( $4 ) {

                        # unfortunately ignores TZ data
                        $d = sprintf(
                            '%d-%02d-%02dT%sZ',
                            $5, $changes->{ months }->{ $2 },
                            $3, $4
                        );
                    }
                    else {
                        $d = sprintf( '%d-%02d-%02d',
                            $5, $changes->{ months }->{ $2 }, $3 );
                    }
                }

                # RFC 2822
                elsif ( $n
                    =~ m{^(\D{3}, (\d{1,2}) (\D{3}) (\d{4}) (\d\d:\d\d:\d\d) ([+-])(\d{2})(\d{2}))}
                    )
                {
                    $match = $1;
                    $d = sprintf(
                        '%d-%02d-%02dT%s%s%02d:%02d',
                        $4, $changes->{ months }->{ $3 },
                        $2, $5, $6, $7, $8
                    );
                }

                # handle dist-zilla style, puts TZ data in note
                elsif ( $n
                    =~ m{^((\d{4}-\d\d-\d\d)\s+(\d\d:\d\d(?::\d\d)?))(?:\s+[A-Za-z]+/[A-Za-z_-]+)} )
                {
                    $match = $1;
                    $d = sprintf( '%sT%sZ', $2, $3 );
                }

                # start with W3CDTF, ignore rest
                elsif ( $n =~ m{^($W3CDTF_REGEX)} ) {
                    $match = $1;
                    $d = $match;
                    $d =~ s{ }{T};
                    # Add UTC TZ if date ends at H:M, H:M:S or H:M:S.FS
                    $d .= 'Z' if length( $d ) == 16 || length( $d ) == 19 || $d =~ m{\.\d+$};
                }

                # clean date from note
                $n =~ s{^\Q$match\E\s*}{};
            }

            undef $d unless length $d;
            undef $n unless length $n;

            push @releases,
                CPAN::Changes::Release->new(
                version      => $v,
                date         => $d,
                _parsed_date => $match,
                note         => $n,
                );
            $ingroup = undef;
            $indent  = undef;
            next;
        }

        # Grouping
        if ( $l =~ m{^\s+\[\s*([^\[\]]+?)\s*\]\s*$} ) {
            $ingroup = $1;
            $releases[ -1 ]->add_group( $1 );
            next;
        }

        $ingroup = '' if !defined $ingroup;

        next if $l =~ m{^\s*$};

        if ( !defined $indent ) {
            $indent
                = $l =~ m{^(\s+)}
                ? '\s' x length $1
                : '';
        }

        $l =~ s{^$indent}{};

        # Inconsistent indentation between releases
        if ( $l =~ m{^\s} && !@{ $releases[ -1 ]->changes( $ingroup ) } ) {
            $l =~ m{^(\s+)};
            $indent = $1;
            $l =~ s{^\s+}{};
        }

        # Change line cont'd
        if ( $l =~ m{^\s} ) {
            $l =~ s{^\s+}{};
            my $changeset = $releases[ -1 ]->changes( $ingroup );
            $changeset->[ -1 ] .= " $l";
        }

        # Start of Change line
        else {
            $l =~ s{^[^[:alnum:]]+\s}{};    # remove leading marker
            $releases[ -1 ]->add_changes( { group => $ingroup }, $l );
        }

    }

    $changes->preamble( $preamble );
    $changes->releases( @releases );

    return $changes;
}

sub preamble {
    my $self = shift;

    if ( @_ ) {
        my $preamble = shift;
        $preamble =~ s{\s+$}{}s;
        $self->{ preamble } = $preamble;
    }

    return $self->{ preamble };
}

sub releases {
    my $self = shift;

    if ( @_ ) {
        $self->{ releases } = {};
        $self->add_release( @_ );
    }

    my $sort_function = sub {
        (   eval {
                ( my $v = $a->version ) =~ s/-TRIAL$//;
                version->parse( $v );
            }
                || 0
            ) <=> (
            eval {
                ( my $v = $b->version ) =~ s/-TRIAL$//;
                version->parse( $v );
            }
                || 0
            ) or ( $a->date || '' ) cmp( $b->date || '' );
    };

    my $next_token = $self->{ next_token };

    my $token_sort_function = sub {
        $a->version =~ $next_token - $b->version =~ $next_token
            or $sort_function->();
    };

    my $sort = $next_token ? $token_sort_function : $sort_function;

    return sort $sort values %{ $self->{ releases } };
}

sub add_release {
    my $self = shift;

    for my $release ( @_ ) {
        my $new = Scalar::Util::blessed $release ? $release
            : CPAN::Changes::Release->new( %$release );
        $self->{ releases }->{ $new->version } = $new;
    }
}

sub delete_release {
    my $self = shift;

    delete $self->{ releases }->{ $_ } for @_;
}

sub release {
    my ( $self, $version ) = @_;

    return unless exists $self->{ releases }->{ $version };
    return $self->{ releases }->{ $version };
}

sub delete_empty_groups {
    my $self = shift;

    $_->delete_empty_groups for $self->releases;
}

sub serialize {
    my $self = shift;
    my %args = @_;

    my %release_args;
    $release_args{ group_sort } = $args{ group_sort } if $args{ group_sort };

    my $output;

    $output = $self->preamble . "\n\n" if $self->preamble;

    my @r = $self->releases;
    @r = reverse @r unless $args{reverse};  # not a typo!

    $output .= $_->serialize( %release_args ) for @r;
    $output =~ s/\n\n+\z/\n/;

    return $output;
}

1;

__END__