File Coverage

lib/Web/DataService/Format.pm

Criterion	Covered	Total	%
statement	47	90	52.2
branch	15	64	23.4
condition	16	56	28.5
subroutine	6	8	75.0
pod	0	4	0.0
total	84	222	37.8

#
# Web::DataService::Format
#
# This module provides a role that is used by 'Web::DataService'.  It implements
# routines for defining and documenting output formats.
#
# Author: Michael McClennen

use strict;

package Web::DataService::Format;

use Carp 'croak';
use Data::Dumper;

use Moo::Role;


our (%FORMAT_DEF) = (name => 'ignore',
		     suffix => 'single',
		     title => 'single',
		     content_type => 'single',
		     disposition => 'single',
		     uses_header => 'single',
		     is_text => 'single',
		     encode_as_text => 'single',
		     default_vocab => 'single',
		     doc_node => 'single',
		     module => 'single',
		     package => 'single',
		     doc_string => 'single',
		     undocumented => 'single',
		     disabled => 'single');

our (%FORMAT_CT) = (json => 'application/json',
		    txt => 'text/plain',
		    tsv => 'text/tab-separated-values',
		    csv => 'text/csv',
		    xml => 'text/xml');

our (%FORMAT_CLASS) = (json => 'Web::DataService::Plugin::JSON',
		       txt => 'Web::DataService::Plugin::Text',
		       tsv => 'Web::DataService::Plugin::Text',
		       csv => 'Web::DataService::Plugin::Text',
		       xml => 'Web::DataService::Plugin::XML');


# define_format ( attrs... )
#
# Define one or more formats for data service responses.

sub define_format {

    my $ds = shift;

    my ($last_node);

    # Now we go through the rest of the arguments.  Hashrefs define new
    # vocabularies, while strings add to the documentation of the vocabulary
    # whose definition they follow.

    foreach my $item (@_)
    {
	# A hashref defines a new vocabulary.

	if ( ref $item eq 'HASH' )
	{
	    # Make sure the attributes include 'name'.

	    my $name = $item->{name};

	    croak "define_format: the attributes must include 'name'" unless defined $name;

	    # Make sure this format was not already defined by a previous call.

	    croak "define_format: '$name' was already defined" if defined $ds->{format}{$name};

	    # Create a new record to represent this format and check the attributes.

	    my $record = bless { name => $name }, 'Web::DataService::Format';

	    foreach my $k ( keys %$item )
	    {
		croak "define_format: invalid attribute '$k'" unless $FORMAT_DEF{$k};

		my $v = $item->{$k};

		if ( $k eq 'default_vocab' && defined $v && $v ne '' )
		{
		    croak "define_format: unknown vocabulary '$v'"
			unless ref $ds->{vocab}{$v};

		    croak "define_format: cannot default to disabled vocabulary '$v'"
			if $ds->{vocab}{$v}{disabled} and not $item->{disabled};
		}

		$record->{$k} = $item->{$k};
	    }

	    # Set defaults and check values.

	    $record->{content_type} ||= $FORMAT_CT{$name};
	    $record->{uses_header} //= 1 if $name eq 'txt' || $name eq 'tsv' || $name eq 'csv';
	    $record->{is_text} //= 1 if $record->{content_type} =~ /(x(?:ht)?ml|text|json|javascript)/
		|| $record->{encode_as_text};

	    croak "define_format: you must specify an HTTP content type for format '$name' using the attribute 'content_type'"
		unless $record->{content_type};

	    $record->{package} //= $record->{module};
	    $record->{package} //= $FORMAT_CLASS{$name};

	    croak "define_format: you must specify a package to implement format '$name' using the attribute 'module'"
		unless defined $record->{package};

	    $record->{module} //= $record->{package};

	    # Make sure that the module is loaded, unless the format is disabled.

	    if ( $record->{module} && ! $record->{disabled} )
	    {
		my $filename = $record->{module};
		$filename =~ s{::}{/}g;
		$filename .= '.pm' unless $filename =~ /\.pm$/;

		require $filename;
	    }

	    # Now store the record as a response format for this data service.

	    $ds->{format}{$name} = $record;
	    push @{$ds->{format_list}}, $name unless $record->{disabled};
	    $last_node = $record;
	}

	# A scalar is taken to be a documentation string.

	elsif ( not ref $item )
	{
	    $ds->add_node_doc($last_node, $item);
	}

	else
	{
	    croak "define_format: the arguments to this routine must be hashrefs and strings";
	}
    }

    croak "define_format: you must include at least one hashref of attributes"
	unless $last_node;
}


# list_formats ( )
#
# Return the list of names of all the formats that have been defined for this
# data service.

sub list_formats {

    my ($ds) = @_;
    return @{$ds->{format_list}};
}


# valid_format ( )
#
# Return a code reference (actually a reference to a closure) that can be used
# in a parameter rule to validate a format-selecting parameter.  All
# non-disabled formats are included.

sub format_validator {

    my ($self) = @_;

    # The ENUM_VALUE subroutine is defined by HTTP::Validate.pm.

    return ENUM_VALUE(@{$self->{format_list}});
}


# document_formats ( path, options )
#
# Return a string containing POD documentation of the response formats that
# are allowed for the request path.  If the root path '/' is specified, then
# document all of the formats enabled for this data service regardless of
# whether they are actually allowed for that path.  But formats marked as
# undocumented are never shown.  If the option 'extended' is specified, then
# include the text description of each format.

sub document_formats {

    my ($ds, $path, $options) = @_;

    $options ||= {};
    $path ||= '/';

    # If no formats have been defined, return a note to that effect.

    return "MSG_FORMAT_NONE_DEFINED"
	unless ref $ds->{format_list} eq 'ARRAY';

    # Now figure out which formats to document.  If the path is '/', then
    # document all of them.  Otherwise, go thorugh the list of defined formats
    # in order, filtering out those which are not allowed for this path.  The
    # reason for doing it this way is so that the formats will always be
    # listed in the order defined, instead of the arbitrary hash order.

    my @formats;

    if ( $path eq '/' )
    {
	@formats = grep { ! $ds->{format}{$_}{undocumented} } @{$ds->{format_list}};
	return "MSG_FORMAT_NONE_DEFINED" unless @formats;
    }

    else
    {
	my $allowed = $ds->node_attr($path, 'allow_format');

	return "MSG_FORMAT_NONE_ALLOWED"
	    unless ref $allowed eq 'HASH';

	@formats = grep { $allowed->{$_} && ! $ds->{format}{$_}{undocumented} } @{$ds->{format_list}};
	return "MSG_FORMAT_NONE_ALLOWED" unless @formats;
    }

    # Go through the list of defined formats in order,

    my @paths = grep { $ds->{format}{$_}{doc_node} } @formats;

    my $name_header = $ds->has_feature('format_suffix') ? 'Suffix' : 'Name';
    my $ext_header = $options->{extended} || ! @paths ? "| Description" : '';
    my $doc_header = @paths ? "| Documentation" : '';

    my $doc = "=for wds_table_header Format* | $name_header $doc_header $ext_header\n\n";
    $doc .= "=over 4\n\n";

 FORMAT:
    foreach my $name (@formats)
    {
	my $frec = $ds->{format}{$name};
	my $title = $frec->{title} || $frec->{name};
	my $doc_link = $ds->node_link($frec->{doc_node}) if $frec->{doc_node};
	my $name_or_suffix = $ds->has_feature('format_suffix') ? ".$frec->{name}" : $frec->{name};

	next FORMAT if $frec->{undocumented};

	$doc .= "=item $title | C<$name_or_suffix>";
	$doc .= " | $doc_link" if $doc_link && @paths && $options->{extended};
	$doc .= "\n\n";

	if ( $options->{extended} || ! @paths )
	{
	    $doc .= "$frec->{doc_string}\n\n" if $frec->{doc_string};
	}

	elsif ( $doc_link )
	{
	    $doc .= "$doc_link\n\n";
	}
    }

    $doc .= "=back";

    return $doc;
}


1;