File Coverage

blib/lib/XML/CSV.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

package XML::CSV;

use Text::CSV_XS;
use Carp;

#use strict;
BEGIN
{
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require 5.004;
require Exporter;
#require DynaLoader;
require AutoLoader;

@ISA = qw(Exporter);# DynaLoader);

@EXPORT = qw(

);
$VERSION = '0.14';
};
#bootstrap XML::CSV $VERSION;

my $xml_xs_obj;  #Declared for global usage
my $csvxml_error;  #Error container


sub new($;$)
{

	my $class = shift;
	my $attr = shift || {};

	my $self =	{  	'error_out' => 0,
		   		'column_headings' => 0,
		   		'column_data' => 0,
		   		'csv_xs' => 0,
		   		%$attr
			};

	bless $self, $class;

	if ($attr->{csv_xs})  ### if custom Text::CSV_XS object is provided use it
	{
		$xml_xs_obj = $attr->{csv_xs};
		$attr->{csv_xs} = undef;
	} else {   	      ### else create our own Text::CSV_XS object with it's defaults
		$xml_xs_obj = Text::CSV_XS->new();
	}



	return $self;

}

sub parse_doc
{
	my $class = shift;
	my $file_name = shift || croak "Usage: parse_doc(file_name, [\%attr])";
	my $attr = shift;  # %attr (headings, sub_char)

	eval {open FILE_CSV, "$file_name";};

	$csvxml_error = "Couldn't open file: $file_name.  $@" if $@;

	croak "$csvxml_error" if ($class->{'error_out'} == 1 && $@);

	my @col_headings;

	$attr->{headings} = 0 unless (exists($attr->{headings}));  ### default headings to 0

	if ($attr->{headings} == 0)  ### No headings to be used from file
	{
		if ($class->{column_headings})
		{
			@col_headings = @{$class->{column_headings}};   ### if column_heading are provided
		} 			                                ### by user, use them

	}

	my $line;  ### declare $line outside of scope to be use later

	if ($attr->{headings} != 0)
	{
		$line = ;
		my $cols_returned = $get_header->($line, \@col_headings, defined($attr->{sub_char})? $attr->{sub_char}:undef );
		$csvxml_error = "There were no columns returned for headers, please check your CSV file" if (!$cols_returned);

		croak "$csvxml_error" if ($class->{'error_out'} == 1);

		return 0 if (!$cols_returned);
	}

	my @arr_cols_data;   ### declare @arr_cols_data to be used for stacking data

	while ($line = )
	{

 	my @cols_data;
	my $status = $xml_xs_obj->parse($line);  ### parse line by line
	@cols_data = $xml_xs_obj->fields();  ### CSV_XS method returns data array for line passed
	$escape_char->(\@cols_data);
	push @arr_cols_data, \@cols_data;    ### stack the returned data

	}

	$class->{'column_headings'} = \@col_headings;  ### assign reference of @col_headings (xml headers) to object
	$class->{'column_data'} = \@arr_cols_data;     ### assign reference of @arr_cols_data (xml data) to object

	close FILE_CSV;

	return 1;
}

sub print_xml
{
	my $class = shift;
	my $file_out = shift || 0;
	my $args = shift || {};  # %attr (file_tag, parent_tag, format)

	$args->{file_tag} = "records" unless $args->{file_tag};  #default {parent_tag} to record if not supplied
	$args->{parent_tag} = "record" unless $args->{parent_tag};
	$args->{format} = "\t" unless $args->{format};  #default {format} to tab if not supplied

	$class->{'document_element'} = $args->{file_tag};  ### Used later for declare_doctype() method

	if ($class->{'column_data'} == 0 || ($class->{'column_headings'} == 0 && $class->{'headings'}))
	{
		croak "There is no data to print, make sure that you parsed the document before printing";
	}

	###Open file $file_out for output or output to STDOUT
	if ($file_out)
	{
		open FILE_OUT, ">$file_out";
	} else {
		*FILE_OUT = *STDOUT;
	}

	print FILE_OUT $class->{'declare_xml'}."\n" if $class->{'declare_xml'};
	###This will replace the non-interpolated $class->{'document_element'} inside the $class->{'declare_doctype'} to get the real value
	###Should be replace with something more practical in the future...
	$class->{'declare_doctype'} =~ s/\$class\-\>\{\'document_element\'\}/$class->{'document_element'}/ if $class->{'declare_doctype'};

	print FILE_OUT $class->{'declare_doctype'}."\n" if $class->{'declare_doctype'};
	print FILE_OUT "<$args->{file_tag}>", "\n";	### print initial document tag

	### declare the $tag for <$tag> and $loop_num for headers and data index tracking
	my $tag;
	my $loop_num;

	if ($#{$class->{'column_headings'}} > 0)  ### if column headings are provided
	{

		foreach $loop_num (0..$#{$class->{'column_data'}})
		{
			print FILE_OUT $args->{format}, "<$args->{parent_tag}>", "\n";
			foreach $tag (0..$#{$class->{'column_headings'}})
			{
				print FILE_OUT $args->{format}, $args->{format}, "<$class->{'column_headings'}[$tag]>$class->{'column_data'}[$loop_num][$tag]{'column_headings'}[$tag]>\n";
			}
			print FILE_OUT $args->{format}, "{parent_tag}>", "\n";
		}

	} else {  ### if column headings are not provided we default to

		foreach $loop_num (0..$#{$class->{'column_data'}})
		{
	       		print FILE_OUT $args->{format}, "<$args->{parent_tag}>", "\n";
			foreach $tag (0..$#{$class->{'column_data'}->[$loop_num]})
			{
				print FILE_OUT $args->{format}, $args->{format}, "$class->{'column_data'}[$loop_num][$tag]\n";
			}
			print FILE_OUT $args->{format}, "{parent_tag}>", "\n";
		}
	}

	print FILE_OUT "{file_tag}>", "\n";  ### print the final document tag

	close FILE_OUT;

}


sub declare_xml
{

	my $class = shift;
	my $attr = shift || {};

	### Attributes: version, encoding, standalone

	if (exists $attr->{'version'})
	{
		$class->{'declare_xml'} = "{'version'}\""
	}
	else
	{
		$csvxml_error = "The version attribute must be specified for declare_xml()\n
				Usage: declare_xml\({version=>1.0, [encoding=>..., standalone=>yes/no]}\)";
		croak "$csvxml_error" if ($class->{'error_out'} == 1);
	}

	$class->{'declare_xml'} .= " encoding=\"$attr->{'encoding'}\"" if exists $attr->{'encoding'};
	if (exists $attr->{'standalone'} && ($attr->{'standalone'} =~ /[yes|no]/))
	{
		$class->{'declare_xml'} .= " standalone=\"$attr->{'standalone'}\"";
	}
	elsif (!($attr->{'standalone'} =~ /[yes|no]/))
	{
		$csvxml_error = "The standalone attribute must be yes|no for declare_xml()\n
				Usage: declare_xml\({version=>1.0, [encoding=>..., standalone=>yes/no]}\)";
		croak "$csvxml_error" if ($class->{'error_out'} == 1);
	}

	$class->{'declare_xml'} .= "?>";

	return $class->{'declare_xml'};

}

sub declare_doctype
{

	my $class = shift;
	my $attr = shift || {};

	### Attributes: source, location1, location2, subset

	$class->{'declare_doctype'} = '{\'document_element\'}';
	if ($attr->{source} eq "SYSTEM" || $attr->{source} eq "PUBLIC")
	{
		$class->{'declare_doctype'} .= " $attr->{'source'}";
	}
	else
	{
		$csvxml_error = "The source attribute is not set correctly";
		croak "$csvxml_error" if ($class->{'error_out'} == 1);
	}

	if (exists $attr->{location1} && !(exists $attr->{subset}))
	{
		$class->{'declare_doctype'} .= " \"$attr->{'location1'}\"";
	}
	else
	{
		$csvxml_error = "$attr->{'source'} location1 must be specified";
		croak "$csvxml_error" if ($class->{'error_out'} == 1);
	}

	$class->{'declare_doctype'} .= " \"$attr->{'location2'}\"" if exists $attr->{'location2'};
	$class->{'declare_doctype'} .= " [$attr->{'subset'}]" if exists $attr->{'subset'};


	$class->{'declare_doctype'} .= ">";

	return $class->{'declare_doctype'};

}

$get_header = sub()
{
	my $line = shift;
	my $ref_col = shift;
	my $sub_char = shift;

	my $status = $xml_xs_obj->parse($line);
	@$ref_col = $xml_xs_obj->fields();

	if (defined($sub_char))
	{
		map {s/^([^a-zA-Z|_|:]|((x|X)(m|M)(l|L)))/$sub_char/g;} @$ref_col;  #convert all beginning \n or \t or \s to '_'
		map {s/[^a-zA-Z|^-|^.|^0-9|^:]/$sub_char/g;} @$ref_col;
	}

	#print __LINE__.": $ref_col->[0]\n";

	if ($ref_col) {return $#$ref_col;}else{return 0;}
};

$escape_char = sub()  ### Escape char per XML 1.0 specifications
{                     ### Needs to be optimized for faster processing

	my $arg = shift;
	if (ref($arg) eq 'ARRAY')
	{
		my $arr_index;
		foreach $arr_index (0..$#{$arg})
		{
			@{$arg}[$arr_index] =~ s/\&/\&\;/g;
			@{$arg}[$arr_index] =~ s/\
			@{$arg}[$arr_index] =~ s/\>/\>\;/g;
			@{$arg}[$arr_index] =~ s/\'/\&apos\;/g;
			@{$arg}[$arr_index] =~ s/\"/\"\;/g;
		}
	}
	elsif (ref($arg) eq 'SCALAR')
	{
		${$arg} =~ s/\&/\&\;/g;
		${$arg} =~ s/\
		${$arg} =~ s/\>/\>\;/g;
		${$arg} =~ s/\'/\&apos\;/g;
		${$arg} =~ s/\"/\"\;/g;
		${$arg} =~ s/([\x80-\xFF])/$XmlUtf8Encode->(ord($1))/ge;
	}
	else
	{
		croak "Usage: $escape_char->(\@cols_data) or $escape_char->(\$foo)\n";
	}

};

$XmlUtf8Encode = sub() {

    my $n = shift;
    if ($n < 0x80) {
        return chr ($n);
    } elsif ($n < 0x800) {
        return pack ("CC", (($n >> 6) | 0xc0), (($n & 0x3f) | 0x80));
    } elsif ($n < 0x10000) {
        return pack ("CCC", (($n >> 12) | 0xe0), ((($n >> 6) & 0x3f) | 0x80),
                     (($n & 0x3f) | 0x80));
    } elsif ($n < 0x110000) {
        return pack ("CCCC", (($n >> 18) | 0xf0), ((($n >> 12) & 0x3f) | 0x80),
                     ((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80));
    }
    return $n;
};


# Preloaded methods go here.

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__