/usr/local/CPAN/Net-IPP/Net/IPP/IPPAttribute.pm
###
# Copyright (c) 2004 Matthias Hilbig <bighil@cpan.org>
# All rights reserved.
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
package Net::IPP::IPPAttribute;
use strict;
use warnings;
use Carp;
use Net::IPP::IPP qw(:all);
require Exporter;
our @ISA = ("Exporter");
our @EXPORT_OK = qw(encodeAttribute decodeAttribute);
our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
# this variable is set to 1 by IPPRequest.pm to turn HP Bugfixing on
#
# one of the HP printers encodes the values of NAME_WITH_LANGUAGE and
# TEXT_WITH_LANGUAGE types wrong:
#
# rfc conform encoding:
# val_length[lang_length[lang]name_length[name]]
#
# HP uses instead:
# lang_length[lang]name_length[name]
#
our $HP_BUGFIX = 0;
#
# Hash which associates attribute names with default IPP type.
# This default type can be overwritten with hash notation:
#
# "requesting-user-name" => { &TYPE => &NAME_WITH_LANGUAGE,
# &VALUE => "de, root" }
#
# TODO: enter all attributes that can be used in IPP requests
my %attributeTypes = (
# operation attributes belong into the operation group
"attributes-charset" => &CHARSET,
"attributes-natural-language" => &NATURAL_LANGUAGE,
"printer-uri" => &URI,
"which-jobs" => &KEYWORD,
"job-uri" => &URI,
"job-id" => &INTEGER,
"requesting-user-name" => &NAME_WITHOUT_LANGUAGE,
"document-format" => &MIME_MEDIA_TYPE,
"document-name" => &NAME_WITHOUT_LANGUAGE,
"requested-attributes" => &KEYWORD,
"limit" => &INTEGER,
"printer-info" => &TEXT_WITHOUT_LANGUAGE,
"printer-location" => &TEXT_WITHOUT_LANGUAGE,
"printer-type" => &ENUM,
# job-template-attributes
"job-priority" => &INTEGER,
"job-hold-until" => &KEYWORD,
"job-sheets" => &KEYWORD,
"multiple-document-handling" => &KEYWORD,
"copies" => &INTEGER,
"finishings" => &ENUM,
"page-ranges" => &RANGE_OF_INTEGER,
"sides" => &KEYWORD,
"number-up" => &INTEGER,
"orientation-requested" => &ENUM,
"media" => &KEYWORD,
"media-ready" => &KEYWORD,
"printer-resolution" => &RESOLUTION,
"print-quality" => &ENUM,
);
###
# Encode attribute to bytes.
#
# Parameters: $name - name of attribute
# $value - value of attribute
#
# Return: byte encoded attribute
#
sub encodeAttribute($$) {
my $name = shift;
my $value = shift;
my $type;
if (ref($value) eq "HASH") {
#if value is hashref, overwrite default IPP type
if (exists($value->{&TYPE})) {
$type = $value->{&TYPE};
}
if (!exists($value->{&VALUE})) {
confess "Could not find value in Hash.\n";
} else {
$value = $value->{&VALUE};
}
}
if (!$type) {
if (exists($attributeTypes{$name})) {
$type = $attributeTypes{$name};
} else {
# look if template attribute and then use type of base type
my $base;
if ($name =~ /^(.*)\-(default|supported)$/) {
$base = $1;
}
if (exists($attributeTypes{$base})) {
$type = $attributeTypes{$name};
} else {
confess "Error: Unknown attribute $name used in request.";
}
}
}
my $bytes = "";
if (ref($value) eq "ARRAY") {
#if value is arrayref encode isSet
my $size = scalar(@{$value});
for (my $i = 0; $i < $size; $i++) {
$bytes .= pack("C", $type);
my $tValue = transformValue($type, $name, $value->[$i], 0);
if ($i == 0) {
$bytes .= pack("n/a*n/a*", $name, $tValue);
} else {
$bytes .= pack("nn/a*",0,$tValue);
}
}
} else {
#normal encoding
$bytes .= pack("C", $type);
$value = transformValue($type, $name, $value, 0);
$bytes .= pack("n/a*n/a*", $name, $value);
}
return $bytes;
}
###
# Transforms attribute value, two modes are available: encoding and decoding
#
# Parameter: $type - IPP type to use
# $value - value to transform
# $decode - 1 for decoding, 0 for encoding
#
# Return: transformed value
#
sub transformValue($$$$) {
my $type = shift;
my $key = shift;
my $value = shift;
my $decode = shift;
if ($type == &TEXT_WITHOUT_LANGUAGE
|| $type == &NAME_WITHOUT_LANGUAGE) {
#RFC: textWithoutLanguage, LOCALIZED-STRING.
#RFC: nameWithoutLanguage
return $value;
} elsif ($type == &TEXT_WITH_LANGUAGE
|| $type == &NAME_WITH_LANGUAGE) {
#RFC: textWithLanguage OCTET-STRING consisting of 4 fields:
#RFC: a. a SIGNED-SHORT which is the number of
#RFC: octets in the following field
#RFC: b. a value of type natural-language,
#RFC: c. a SIGNED-SHORT which is the number of
#RFC: octets in the following field,
#RFC: d. a value of type textWithoutLanguage.
#RFC: The length of a textWithLanguage value MUST be
#RFC: 4 + the value of field a + the value of field c.
if ($decode) {
if ($IPPAttribute::HP_BUGFIX) {
return $value;
} else {
my ($language, $text) = unpack("n/a*n/a*", $value);
return "$language, $text";
}
} else {
#TODO: test if HP needs bugfix also for encoding
$value =~ /^\s*([^,]*?)\s*,\s*([^,]*?)\s*$/;
return pack("n/a*n/a*", $1, $2);
}
} elsif ($type == &CHARSET
|| $type == &NATURAL_LANGUAGE
|| $type == &MIME_MEDIA_TYPE
|| $type == &KEYWORD
|| $type == &URI
|| $type == &URI_SCHEME) {
#RFC: charset, US-ASCII-STRING.
#RFC: naturalLanguage,
#RFC: mimeMediaType,
#RFC: keyword, uri, and
#RFC: uriScheme
return $value;
} elsif ($type == &BOOLEAN) {
#RFC: boolean SIGNED-BYTE where 0x00 is 'false' and 0x01 is
#RFC: 'true'.
if ($decode) {
return unpack("c", $value);
} else {
if ($value) {
return "\01";
} else {
return "\00";
}
}
} elsif ($type == &INTEGER
|| $type == &ENUM) {
#RFC: integer and enum a SIGNED-INTEGER.
if ($decode) {
return unpack("N", $value);
} else {
return pack("N", $value);
}
} elsif ($type == &DATE_TIME) {
#RFC: dateTime OCTET-STRING consisting of eleven octets whose
#RFC: contents are defined by "DateAndTime" in RFC
#RFC: 1903 [RFC1903].
if ($decode) {
my ($year, $month, $day, $hour, $minute, $seconds, $deciSeconds, $direction, $utcHourDiff, $utcMinuteDiff)
= unpack("nCCCCCCaCC", $value);
return "$month-$day-$year,$hour:$minute:$seconds.$deciSeconds,$direction$utcHourDiff:$utcMinuteDiff";
} else {
if ($value =~ /^\s*(\d+)\s*-\s*(\d+)\s*-\s*(\d+)\s*,\s*(\d+)\s*:\s*(\d+)\s*:\s*(\d+)\s*.\s*(\d+)\s*,\s*([\-\+])\s*(\d+)\s*:\s*(\d+)\s*$/) {
return pack("nCCCCCCaCC", $3, $1, $2, $4, $5, $6, $7, $8, $9, $10);
} else {
carp("Unable to parse date: $value");
return "\00" x 8 . "+" . "\00\00";
}
}
} elsif ($type == &RESOLUTION) {
#RFC: resolution OCTET-STRING consisting of nine octets of 2
#RFC: SIGNED-INTEGERs followed by a SIGNED-BYTE. The
#RFC: first SIGNED-INTEGER contains the value of
#RFC: cross feed direction resolution. The second
#RFC: SIGNED-INTEGER contains the value of feed
#RFC: direction resolution. The SIGNED-BYTE contains
#RFC: the units
# unit: 3 = dots per inch
# 4 = dots per cm
if ($decode) {
my ($crossFeedResolution, $feedResolution, $unit) = unpack("NNc", $value);
my $unitText;
if ($unit == 3) {
$unitText = "dpi";
} elsif ($unit == 4) {
$unitText = "dpc";
} else {
carp ("Unknown Unit value: $unit");
$unitText = $unit;
}
return "$crossFeedResolution, $feedResolution $unitText";
} else {
my ($crossFeedResolution, $feedResolution, $unitText) =
$value =~ /^\s*(\d+)\s*,\s*(\d+)\s*(\w+)\s*$/;
my $unit;
if ($unitText eq "dpi") {
$unit = 3;
} elsif ($unitText eq "dpc") {
$unit = 4;
} else {
carp ("Unknown Unit: $unitText using dpi instead.");
$unit = 3;
}
return pack("NNc", $crossFeedResolution, $feedResolution, $unit);
}
} elsif ($type == &RANGE_OF_INTEGER) {
#RFC: rangeOfInteger Eight octets consisting of 2 SIGNED-INTEGERs.
#RFC: The first SIGNED-INTEGER contains the lower
#RFC: bound and the second SIGNED-INTEGER contains
#RFC: the upper bound.
if ($decode) {
my ($lowerBound, $upperBound) = unpack("NN", $value);
return "$lowerBound:$upperBound";
} else {
my ($lowerBound, $upperBound) =
$value =~ /^\s*(\d+)\s*:\s*(\d+)\s*$/;
return pack("NN", $lowerBound, $upperBound);
}
} elsif ($type == &OCTET_STRING) {
#RFC: octetString OCTET-STRING
return $value;
} elsif ($type == &BEG_COLLECTION) {
if ($key) {
carp "WARNING: Collection Syntax not supported. Attribute \"$key\" will have invalid value.\n";
}
} elsif ($type == &END_COLLECTION
|| $type == &MEMBER_ATTR_NAME) {
return $value;
} else {
carp "Unknown Value type ", sprintf("%#lx",$type) , " for key \"$key\". Performing no transformation.";
return $value;
}
}
###
# print warning if the key does not consist of word symbols and -, as
# then something went probably wrong.
#
# Parameter: $key - attribute key to test
#
sub testKey($) {
my $key = shift;
if (not $key =~ /^[\w\-]*$/) {
carp ("Probably wrong attribute key: $key\n");
}
}
###
# test if response is RFC conform: if lengths of key or value is
# longer than remaining bytes, something went wrong while decoding.
#
# As there are (hopefully :-)) no bugs in the decoding functions, the response
# is not RFC conform.
#
# TODO: maybe implement length check for different attribute types:
# maximum lengths of the different types:
# 'textWithLanguage <= 1023 AND 'naturalLanguage' <= 63
# 'textWithoutLanguage' <= 1023
# 'nameWithLanguage' <= 255 AND 'naturalLanguage' <= 63
# 'nameWithoutLanguage' <= 255
# 'keyword' <= 255
# 'enum' = 4
# 'uri' <= 1023
# 'uriScheme' <= 63
# 'charset' <= 63
# 'naturalLanguage' <= 63
# 'mimeMediaType' <= 255
# 'octetString' <= 1023
# 'boolean' = 1
# 'integer' = 4
# 'rangeOfInteger' = 8
# 'dateTime' = 11
# 'resolution' = 9
# '1setOf X'
#
sub testLengths($$) {
use bytes;
my $bytes = shift;
my $offset = shift;
my $keyLength = unpack("n", substr($bytes, $offset, 2));
if ($offset + 2 + $keyLength > length($bytes)) {
my $dump = bytesToString($bytes);
print STDERR "---IPP RESPONSE DUMP (current offset: $offset):---\n$dump\n";
confess("ERROR: IPP response is not RFC conform.");
}
my $valueLength = unpack("n", substr($bytes, $offset + 2 + $keyLength, 2));
if ($offset + 4 + $keyLength + $valueLength > length($bytes)) {
my $dump = bytesToString($bytes);
print STDERR "---IPP RESPONSE DUMP (current offset: $offset):\n---$dump\n";
confess("ERROR: IPP response is not RFC conform.");
}
}
###
# Decode next attribute from IPP Response
#
# Parameters: $bytes - IPP Response
# $offsetref - reference to current position in IPP Response
# $type - type of attribute
# $group - reference to group into which to insert the attribute
#
my $previousKey; # used for 1setOf values
sub decodeAttribute($$$$) {
my $bytes = shift;
my $offsetref = shift;
my $type = shift;
my $group = shift;
my $data;
{ use bytes;
$data = substr($bytes, $$offsetref);
}
my ($key, $value, $addValue);
#TODO: novalue
# HP BUG!!!!
if ($IPPAttribute::HP_BUGFIX && ($type == &TEXT_WITH_LANGUAGE
|| $type == &NAME_WITH_LANGUAGE)) {
($key, $value, $addValue) = unpack("n/a* n/a* n/a*", $data);
testKey($key);
{ use bytes;
$$offsetref += 6 + length($key) + length($value) + length($addValue);
}
$value .= ", " . $addValue;
} else {
testLengths($bytes, $$offsetref);
($key, $value) = unpack("n/a* n/a*", $data);
testKey($key);
{ use bytes;
$$offsetref += 4 + length($key) + length($value);
}
}
#for attribute autodetection:
if (&DEBUG) {
if (!exists($attributeTypes{$key})) {
print "Unknown attribute in response:\n";
print "\"$key\" => $type\n";
} elsif($attributeTypes{$key} != $type) {
print "Attribute has unexpected type (instead of ",$attributeTypes{$key},"):\n";
print "\"$key\" => $type\n";
}
}
$value = transformValue($type, $key, $value, 1);
# if key empty, attribute is 1setOf
if (!$key) {
if (!ref($group->{$previousKey})) {
my $arrayref = [$group->{$previousKey}];
$group->{$previousKey} = $arrayref;
}
push @{$group->{$previousKey}}, $value;
} else {
$group->{$key} = $value;
$previousKey = $key;
}
}
1;