File Coverage

blib/lib/Net/IPP/IPPRequest.pm

Criterion	Covered	Total	%
statement	33	116	28.4
branch	0	36	0.0
condition	0	9	0.0
subroutine	11	18	61.1
pod	0	7	0.0
total	44	186	23.6

###
# Copyright (c) 2004 Matthias Hilbig
# All rights reserved.
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
# Perl API for sending IPP requests
#
#    Uses: LWP::UserAgent
#          Carp
#
# Perl files: lib/Net/IPP/IPPRequest.pm   - main API file
#             lib/Net/IPP/IPPAttribute.pm - encodes/decodes IPP attributes
#             lib/Net/IPP/IPPUtil.pm      - helper functions
#             lib/Net/IPP/IPPMethods.pm   - ippRequest wrappers
#             lib/Net/IPP/IPP.pm          - contains all IPP constants
#             sample/ipptest.pl           - IPP lowlevel access example
#             sample/printerAttributes.pl - show IPP attributes of printer
#             sample/showJobs.pl          - show IPP jobs of printer
#             sample/monitorState.pl      - monitor Status of printer
#             sample/monitorJobs.pl       - monitor Status of jobs
#             t/codec.t                   - Testcases for encoding and
#                                           decoding of IPP requests
#             t/transform.t               - Testcases for transformValue
#                                           method
#    for Changes look at the Changes file.
#
#------------------------------------------------------------------------------

package Net::IPP::IPPRequest;

our $VERSION = "0.1";

#TODO: which perl version is required? Maybe 5.6 or something like that
#use 5.008;

use strict;
use warnings;

use Carp;
use LWP::UserAgent;

use Net::IPP::IPP qw(:all);
use Net::IPP::IPPAttribute qw(:all);
use Net::IPP::IPPUtil qw(:all);

require Exporter;
our @ISA = ("Exporter");
our @EXPORT_OK = qw(ippRequest);
our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );


#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# ENCODING
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

###
# encode IPP Header
#
# Parameter: $operation - IPP operation
#            $requestId - id of IPP request
#
# Return: byte encoded IPP Header (length: 8 Byte)
#

sub encodeIPPHeader($$) {
  my $operation = shift;
  my $requestId = shift;
  print("Operation: $operation, RequestID: $requestId\n") if &DEBUG;
  return pack("CCnN",
		   &IPP_MAJOR_VERSION,
		   &IPP_MINOR_VERSION,
		   $operation,
		   $requestId
		  );
}


###
# encode an IPP group with all attributes
#
# Parameter: $attributes - reference to IPP attributes
#
# Return: byte encoding of attributes
#

# TODO: RFC requires ascending order of groups(Idea: test if type numbers of following groups are >=
# previous group type)
sub encodeGroups($) {
  	my $attributes = shift;
  	my $bytes;

	if (!exists($attributes->{&TYPE})) {
		confess ("Type missing in group.");
	}

  	$bytes = pack("C", $attributes->{&TYPE});

  	#
	# "attributes-charset" must be first, "attributes-natural-language"
	# must be second attribute in operation group, also ignore
	# these two attributes in all groups except the operation group
	use constant att_charset => "attributes-charset";
	use constant att_language => "attributes-natural-language";

	if ($attributes->{&TYPE} == &OPERATION_ATTRIBUTES) {
		if (!exists($attributes->{att_charset})) {
			$bytes .= encodeAttribute(att_charset, "utf-8");
		} else {
			$bytes .= encodeAttribute(att_charset, $attributes->{att_charset});
		}

		if (!exists($attributes->{att_language})) {
			$bytes .= encodeAttribute(att_language, "en");
		} else {
			$bytes .= encodeAttribute(att_language, $attributes->{att_language});
		}
	}

	# encode all other attributes
	while (my ($key, $value) = each %{$attributes}) {
    	if ($key ne &TYPE
    		and $key ne att_charset
    		and $key ne att_language) {
    		$bytes .= encodeAttribute($key, $value);
    	}
  	}
  	return $bytes;
}


###
# convert an IPP Request from Perl encoding to Byte encoding
#
# Parameter: $request - IPP request
#
# Return: byte encoding of $request
#

sub hashToBytes($) {
  	my $request = shift;

	if (!exists($request->{&OPERATION}) || !exists($request->{&REQUEST_ID})) {
		confess("Operation or Request-ID is missing in request.");
	}

  	my $bytes = encodeIPPHeader($request->{&OPERATION}, $request->{&REQUEST_ID});

  	foreach my $group (@{$request->{&GROUPS}}) {
    	$bytes .= encodeGroups($group);
  	}

  	$bytes .= pack("C", &END_OF_ATTRIBUTES);

	printBytes($bytes) if &DEBUG;
  	return $bytes;
}

#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# DECODING
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

###
# decode IPPHeader to Perl encoding
#
# Parameter: $bytes - IPP response
#         $response - reference to hash for decoding
#
# Return: decoded values are returned in hash referenced by $response
#
sub decodeIPPHeader($$) {
	my $bytes = shift;
	my $response = shift;

	my $data;
	{use bytes; $data = substr($bytes,0,8);}

	my ($majorVersion, $minorVersion, $status, $requestId) = unpack("CCnN", $data);

	$response->{&VERSION} = $majorVersion . "." . $minorVersion;

	$response->{&STATUS} = $status;

	$response->{&REQUEST_ID} = $requestId;
}


###
# decode all IPP Groups from byte encoding to Perl encoding
#
# Parameter: $bytes - IPP response
#         $response - reference to hash for decoding
#
# Return: decoded values are returned in hash referenced by $response
#
sub decodeIPPGroups($$) {
	my $bytes = shift;
	my $response = shift;

	$response->{&GROUPS} = [];

	# begin directly after IPPHeader (length 8 byte)
	my $offset = 8;
	my $currentGroup = "";
	my $type;

	do {
		{
		use bytes;
		$type = ord(substr($bytes, $offset, 1));
		}

		$offset++;

		if (exists($Net::IPP::IPP::group{$type})) {
			print "group $type found\n" if &DEBUG;
			if ($currentGroup) {
				push @{$response->{&GROUPS}}, $currentGroup;
			}

			if ($type != &END_OF_ATTRIBUTES) {
				$currentGroup = {
					&TYPE => $type
				};
			}
		} elsif ($currentGroup eq "") {
			confess("Expected Group Tag at begin of IPP response.");
		} else {
			decodeAttribute($bytes, \$offset, $type, $currentGroup);
		}
	} while ($type != &END_OF_ATTRIBUTES);
}

###
# Decode whole IPP response from byte encoding to perl encoding
#
# Parameter: $bytes - byte encoded IPP response
#         $response - reference to hash for decoding
#
# Return: decoded values are returned in hash referenced by $response
#

sub bytesToHash($$) {
	my $bytes = shift;
	my $response = shift;

	printBytes($bytes) if &DEBUG;

	decodeIPPHeader($bytes, $response);

	decodeIPPGroups($bytes, $response);

	return $response;
}

#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# IPP Request
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

my $userAgent = LWP::UserAgent->new;
$userAgent->agent("Perl IPP API/$VERSION");

###
# Do the actual IPP request
#
# Parameter: $request - perl encoded IPP request
#
# Return: perl encoded IPP response
#

sub ippRequest($) {
	my $request = shift;
	if (!exists($request->{&URL})) {
		confess("Missed URL in request.");
	}
	my $url = $request->{&URL};

	if (exists($request->{&HP_BUGFIX})) {
		$Net::IPP::IPPAttribute::HP_BUGFIX = $request->{&HP_BUGFIX};
	} else {
		$Net::IPP::IPPAttribute::HP_BUGFIX = 0;
	}

	#convert perl structure to IPP request
	my $content = hashToBytes($request);

	if (exists($request->{&DATA})) {
		$content .= $request->{&DATA};
	}

	# use LWP to send HTTP Post request
	my $httpRequest = HTTP::Request->new(POST => "$url");
	$httpRequest->content_type('application/ipp');
	$httpRequest->content($content);
	my $result = $userAgent->request($httpRequest);

	my $response = {
		&HTTP_CODE => $result->code(),
		&HTTP_MESSAGE => $result->message(),
	};

	if ($result->is_success) {
		#printBytes($result->content);

		#convert response back to perl structure
		return bytesToHash($result->content, $response);
	} else {
		return $response;
	}
}

1;
__END__