File Coverage

blib/lib/App/Changelog2x.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

###############################################################################
#
# This file copyright (c) 2008-2009 by Randy J. Ray, all rights reserved
#
# Copying and distribution are permitted under the terms of the Artistic
# License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php) or
# the GNU LGPL (http://www.opensource.org/licenses/lgpl-license.php).
#
###############################################################################
#
#   Description:    A wrapper in the App::* space for the core functionality
#                   provided by the changelog2x script.
#
#   Functions:      new
#                   version
#                   default_xslt_path
#                   default_date_format
#                   date_format
#                   xslt_path
#                   application_tokens
#                   format_date
#                   credits
#                   transform_changelog
#
#   Libraries:      XML::LibXML
#                   XML::LibXSLT
#                   DateTime
#                   DateTime::Format::ISO8601
#                   File::Spec
#
#   Global Consts:  $VERSION
#                   URI
#
###############################################################################

package App::Changelog2x;

use 5.008;
use strict;
use warnings;
use vars qw($VERSION $FORMAT $DEFAULT_XSLT_PATH);
use subs qw(new version default_xslt_path default_date_format date_format
            xslt_path application_tokens format_date credits
            transform_changelog);
use constant URI => 'http://www.blackperl.com/2009/01/ChangeLogML';

use File::Spec;

use XML::LibXML;
use XML::LibXSLT;
use DateTime;
use DateTime::Format::ISO8601;

BEGIN
{
    $VERSION = '0.11';

    $DEFAULT_XSLT_PATH = (File::Spec->splitpath(__FILE__))[1];
    $DEFAULT_XSLT_PATH = File::Spec->catdir($DEFAULT_XSLT_PATH, 'changelog2x');
}

###############################################################################
#
#   Sub Name:       new
#
#   Description:    Dead-simple constructor. We're just a plain blessed
#                   hashref, here.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $class    in      scalar    Class to bless into
#                   %args     in      hash      Any data to start off with
#
#   Returns:        object referent
#
###############################################################################
sub new
{
    my ($class, %args) = @_;

    my $self = bless {}, $class;

    # If the user didn't pass the xslt_path argument, set up the default
    $args{xslt_path} ||= [ $self->default_xslt_path ];

    foreach (qw(date_format xslt_path))
    {
        # These are the known parameters; if present, call the method to set
        $self->$_(delete $args{$_}) if $args{$_};
    }

    # Copy over any remaining parameters we don't know verbatim
    for (keys %args)
    {
        $self->{$_} = $args{$_};
    }

    $self;
}

# Encapsulated way of retrieving $VERSION, in case someone sub-classes us
sub version             { $VERSION }

# Likewise access to $DEFAULT_XSLT_PATH
sub default_xslt_path   { $DEFAULT_XSLT_PATH }

# And the default date-format
sub default_date_format { '%A %B %e, %Y, %r TZ_SHORT' }

###############################################################################
#
#   Sub Name:       date_format
#
#   Description:    Get or set a default format string for format_date() to
#                   use. If $format is passed, set that as the new format to
#                   use. If no format is set by the user, falls through to
#                   default_date_format().
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $format   in      scalar    New format string
#
#   Returns:        Date format
#
###############################################################################
sub date_format
{
    my ($self, $format) = @_;

    if ($format)
    {
        $self->{format} =
            ($format eq 'unix') ? '%a %b %d %T TZ_SHORT %Y' : $format;
    }

    $self->{format} || $self->default_date_format;
}

###############################################################################
#
#   Sub Name:       xslt_path
#
#   Description:    Return the path to where XSLT files should be searched for.
#                   If this is not set by the user, then return the value for
#                   default_xslt_path(). If a value is passed for $path, make
#                   that the new XSLT directory.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $paths    in      list      New directories to use.
#
#   Returns:        path
#
###############################################################################
sub xslt_path
{
    my ($self, @paths) = @_;

    if (@paths)
    {
        if (ref($paths[0]) eq 'ARRAY')
        {
            $self->{xslt_path} = [ @{$paths[0]} ];
        }
        else
        {
            unshift(@{$self->{xslt_path}}, @paths);
        }
    }

    wantarray ? @{$self->{xslt_path}} : $self->{xslt_path};
}

###############################################################################
#
#   Sub Name:       application_tokens
#
#   Description:    Get/set the string that should be present in the "credits"
#                   string, identifying the application that is using this
#                   class to transform ChangeLogML.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $tokens   in      scalar    If present, string/tokens to
#                                                 store for later use
#
#   Returns:        application tokens
#
###############################################################################
sub application_tokens
{
    my ($self, $tokens) = @_;

    $self->{application_tokens} = $tokens if $tokens;

    $self->{application_tokens};
}

###############################################################################
#
#   Sub Name:       format_date
#
#   Description:    Take a date-string in (ISO 8601 format) and return a
#                   more readable format.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      scalar    Class name or object ref
#                   $date     in      scalar    Date-string in ISO 8601
#                   $to_utc   in      scalar    Boolean flag, whether to
#                                                 convert times to GMT/UTC
#
#   Returns:        Formatted date/time
#
###############################################################################
sub format_date
{
    my ($self, $date, $to_utc) = @_;

    my $dt = DateTime::Format::ISO8601->parse_datetime($date);
    $dt->set_time_zone('UTC') if $to_utc;

    my $string = $dt->strftime($self->date_format);
    if ($string =~ /TZ_/)
    {
        my %tz_edit = ( TZ_LONG  => $dt->time_zone->name,
                        TZ_SHORT => $dt->time_zone->short_name_for_datetime );
        $string =~ s/(TZ_LONG|TZ_SHORT)/$tz_edit{$1}/ge;
    }

    $string;
}

###############################################################################
#
#   Sub Name:       credits
#
#   Description:    Produce a "credits" message for inclusion in transformed
#                   output. Combines app name and version, lib name and
#                   version, etc.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      scalar    Class name or object ref
#
#   Globals:        $cmd
#                   $VERSION
#
#   Returns:        credits string
#
###############################################################################
sub credits
{
    my $self = shift;

    my $credits =
        sprintf("%s/%s, XML::LibXML/%s, XML::LibXSLT/%s, libxml/%s, " .
                "libxslt/%s (with%s exslt)",
                ref($self), $self->version,
                $XML::LibXML::VERSION, $XML::LibXSLT::VERSION,
                XML::LibXML::LIBXML_DOTTED_VERSION(),
                XML::LibXSLT::LIBXSLT_DOTTED_VERSION(),
                (XML::LibXSLT::HAVE_EXSLT() ? '' : 'out'));
    if (my $apptokens = $self->application_tokens)
    {
        $credits = "$apptokens, $credits";
    }

    $credits;
}

###############################################################################
#
#   Sub Name:       transform_changelog
#
#   Description:    Take a filehandle or string for input, a filehandle for
#                   output, filename/string of a XSL transform, and optional
#                   parameters. Process the input according to the XSLT and
#                   stream the results to the output handle.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      scalar    Class name or object ref
#                   $xmlin    in      scalar    Filehandle to read/parse or
#                                                 string
#                   $xmlout   in      ref       Filehandle to output the
#                                                 transformed XML to
#                   $style    in      scalar    Stylesheet, either a string
#                                                 or the name of a file
#                   $params   in      hashref   If present, parameters that
#                                                 should be converted for use
#                                                 in the XSLT and passed in.
#
#   Globals:        URI
#
#   Returns:        Success:    null
#                   Failure:    dies
#
###############################################################################
sub transform_changelog
{
    my ($self, $xmlin, $xmlout, $style, $params) = @_;
    $params ||= {}; # In case they didn't pass any

    our $parser = XML::LibXML->new();
    our $xslt   = XML::LibXSLT->new();

    $parser->expand_xinclude(1);
    $xslt->register_function(URI, 'format-date',
                             sub { $self->format_date(@_) });
    $xslt->register_function(URI, 'credits',
                             sub { $self->credits(@_) });

    our (%params, $xsltc, $source, $stylesheet, $result);

    # If the template isn't already an absolute path, use the root-dir and add
    # the "changelog2" prefix and ".xslt" suffix
    unless ($style =~ /^<\?xml/)
    {
        $xsltc = $self->resolve_template($style)
            or die "Could not resolve style '$style' to a file";
        $style = $xsltc;
    }

    # First copy over and properly setup/escape the parameters, so that XSLT
    # understands them.
    %params = map { XML::LibXSLT::xpath_to_string($_ => $params->{$_}) }
        (keys %$params);

    # Do the steps of parsing XML documents, creating stylesheet engine and
    # applying the transform. Each throws a die on error, so each has to be
    # eval'd to allow for a cleaner error report:
    eval {
        $source = ref($xmlin) ?
            $parser->parse_fh($xmlin) : $parser->parse_string($xmlin);
    };
    die "Error parsing input-XML content: $@" if $@;
    eval {
        $xsltc = ($style =~ /^<\?xml/) ?
            $parser->parse_string($style) : $parser->parse_file($style);
    };
    die "Error parsing the XML of the XSLT stylesheet '$style': $@" if $@;
    eval { $stylesheet = $xslt->parse_stylesheet($xsltc); };
    die "Error parsing the XSLT syntax of the stylesheet: $@" if $@;
    eval { $result = $stylesheet->transform($source, %params); };
    die "Error applying transform to input content: $@" if $@;

    $stylesheet->output_fh($result, $xmlout);
    return;
}

###############################################################################
#
#   Sub Name:       resolve_template
#
#   Description:    Resolve a non-absolute template name to a complete file.
#                   This may include adding "changelog2" and ".xslt" to the
#                   string. If the name is already absolute or starts with a
#                   '.', it is returned unchanged.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $template in      scalar    Name to resolve
#
#   Returns:        Success:    full path
#                   Failure:    empty string
#
###############################################################################
sub resolve_template
{
    my ($self, $template) = @_;

    return $template if ((substr($template, 0, 1) eq '.') ||
                         File::Spec->file_name_is_absolute($template));

    my @paths = $self->xslt_path;
    my $candidate;

    $template = "changelog2$template.xslt" unless ($template =~ /\.xslt?/i);

    for (@paths)
    {
        $candidate = File::Spec->catfile($_, $template);
        last if -f $candidate;
        undef $candidate;
    }

    $candidate;
}

1;

__END__