package Business::UPC;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use subs qw(_check_digit _zeropad _expand_upc_e);
require Exporter;
@ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(
);
$VERSION = '0.04';
# Preloaded methods go here.
sub new
{
my $class = shift;
my $value = shift;
return undef if length($value) > 12;
my ($number_system, $mfr_id, $prod_id, $check_digit) = unpack("AA5A5A", _zeropad $value);
return undef unless $number_system =~ m/^\d$/;
return undef unless $mfr_id =~ m/^\d{5}$/;
return undef unless $prod_id =~ m/^\d{5}$/;
return undef unless $check_digit =~ m/^[\dx]$/i;
return undef if ($number_system == 0 && $mfr_id == 0 && $prod_id == 0);
my $upc = bless {
number_system => $number_system,
mfr_id => $mfr_id,
prod_id => $prod_id,
check_digit => $check_digit,
}, $class;
return $upc;
}
# alternate constructor: for creating from a zero-supressed (type E) value
sub type_e
{
my $class = shift;
my $value = shift;
return undef if length($value) > 8;
my $expanded = _expand_upc_e $value;
return new Business::UPC($expanded) if $expanded;
return undef;
}
sub number_system
{
my $attrname = 'number_system';
my $self = shift;
warn "UPC atribute '$attrname' is not settable." if (@_);
return $self->{$attrname};
}
sub mfr_id
{
my $attrname = 'mfr_id';
my $self = shift;
warn "UPC atribute '$attrname' is not settable." if (@_);
return $self->{$attrname};
}
sub prod_id
{
my $attrname = 'prod_id';
my $self = shift;
warn "UPC atribute '$attrname' is not settable." if (@_);
return $self->{$attrname};
}
sub check_digit
{
my $attrname = 'check_digit';
my $self = shift;
warn "UPC atribute '$attrname' is not settable." if (@_);
return $self->{$attrname};
}
sub as_upc_a
{
my $self = shift;
return $self->number_system . $self->mfr_id
. $self->prod_id . $self->check_digit;
}
sub as_upc
{
my $self = shift;
return $self->as_upc_a
}
sub as_upca_nocheckdigit
{
my $self = shift;
return $self->number_system . $self->mfr_id . $self->prod_id;
}
sub number_system_description
{
my $self = shift;
return $Business::UPC::NumberSystems{$self->number_system};
}
sub coupon_value_code
{
my $self = shift;
return undef unless $self->is_coupon;
return substr($self->prod_id, -2);
}
sub coupon_value
{
my $self = shift;
return undef unless $self->is_coupon;
return $Business::UPC::CouponValues{$self->coupon_value_code};
}
sub coupon_family_code
{
my $self = shift;
return undef unless $self->is_coupon;
return substr($self->prod_id, 0, 3);
}
sub coupon_family_description
{
my $self = shift;
my $cfc = $self->coupon_family_code;
return $Business::UPC::CouponFamilies{$cfc} || 'Unknown';
}
sub is_valid
{
my $self = shift;
return (_check_digit($self->as_upca_nocheckdigit) eq $self->check_digit);
}
sub is_coupon
{
my $self = shift;
return ($self->number_system eq '5');
}
sub fix_check_digit
{
my $self = shift;
$self->{check_digit} = _check_digit($self->as_upca_nocheckdigit);
$self;
}
sub as_upc_e
{
my $self = shift;
my $upca = $self->as_upc_a;
return $upca if ($upca =~ s/^0(\d{2})([012])0000(\d{3})(\d)$/0${1}${3}${2}${4}/);
return $upca if ($upca =~ s/^0(\d{2}[3-9])00000(\d{2})(\d)$/0${1}${2}3${3}/);
return $upca if ($upca =~ s/^0(\d{3}[1-9])00000(\d)(\d)$/0${1}${2}4${3}/);
return $upca if ($upca =~ s/^0(\d{4}[1-9])0000([5-9])(\d)$/0${1}${2}${3}/);
return undef;
}
# private functions: don't use these!
sub _check_digit
{
my $num = shift;
my @digits = split(//, $num);
# To avoid warning when summing below.
push @digits, 0;
my $sum = 0;
foreach my $i (0, 2, 4, 6, 8, 10)
{
$sum += 3 * ($digits[$i] || 0);
$sum += $digits[$i+1] || 0;
}
return (10 - ($sum % 10)) % 10;
}
sub _zeropad
{
my $num = shift;
my $length = shift || 12;
return sprintf("%0${length}s", $num);
}
sub _expand_upc_e
{
my $upc_e = _zeropad shift, 8;
return undef if (length($upc_e) > 8);
return $upc_e if ($upc_e =~ s/^0(\d{2})(\d{3})([012])([\dx])$/0${1}${3}0000${2}${4}/i);
return $upc_e if ($upc_e =~ s/^0(\d{3})(\d{2})3([\dx])$/0${1}00000${2}${3}/i);
return $upc_e if ($upc_e =~ s/^0(\d{4})(\d)4([\dx])$/0${1}00000${2}${3}/i);
return $upc_e if ($upc_e =~ s/^0(.....)([5-9])([\dx])$/0${1}0000${2}${3}/i);
return undef;
}
BEGIN
{
%Business::UPC::NumberSystems = (
'0' => 'Regular Item',
'1' => 'Reserved',
'2' => 'Random-Weight Item',
'3' => 'National Drug/Health-Related Item',
'4' => 'For Private Use',
'5' => 'Coupon',
'6' => 'Regular Item',
'7' => 'Regular Item',
'8' => 'Reserved',
'9' => 'Reserved',
);
%Business::UPC::CouponFamilies = (
'000' => 'Anything from Same Manufacturer',
'001' => 'Reserved',
'002' => 'Reserved',
'003' => 'Reserved',
'004' => 'Reserved',
'005' => 'Reserved',
'006' => 'Reserved',
'007' => 'Reserved',
'008' => 'Reserved',
'009' => 'Reserved',
'990' => 'Reserved',
'991' => 'Reserved',
'992' => 'Reserved',
'993' => 'Reserved',
'994' => 'Reserved',
'995' => 'Reserved',
'996' => 'Reserved',
'997' => 'Reserved',
'998' => 'Reserved',
'999' => 'Reserved',
);
%Business::UPC::CouponValues = (
'00' => 'Checker Intervention',
'01' => 'Free Merchandise',
'02' => 'Buy 4 or more, get 1 free (same product)',
'03' => '$1.10',
'04' => '$1.35',
'05' => 'Reserved for Future Use',
'06' => '$1.60',
'07' => 'Reserved for Future Use',
'08' => 'Reserved for Future Use',
'09' => 'Reserved for Future Use',
'10' => '$0.10',
'11' => '$1.85',
'12' => '$0.12',
'13' => 'Reserved for Future Use',
'14' => 'Buy 1, get 1 free (same product)',
'15' => '$0.15',
'16' => 'Buy 2, get 1 free (same product)',
'17' => '$2.10',
'18' => '$2.60',
'19' => 'Buy 3, get 1 free (same product)',
'20' => '$0.20',
'21' => 'Buy 2 or more, get $0.35 off',
'22' => 'Buy 2 or more, get $0.40 off',
'23' => 'Buy 2 or more, get $0.45 off',
'24' => 'Buy 2, get $0.50 off',
'25' => '$0.25',
'26' => '$2.85',
'27' => 'Reserved for Future Use',
'28' => 'Buy 2, get $0.55 off',
'29' => '$0.29',
'30' => '$0.30',
'31' => 'Buy 2 or more, get $0.60 off',
'32' => 'Buy 2 or more, get $0.75 off',
'33' => 'Buy 2, get $1.00 off',
'34' => 'Buy 2 or more, get $1.25 off',
'35' => '$0.35',
'36' => 'Buy 2 or more, get $1.50 off',
'37' => 'Buy 3 or more, get $0.25 off',
'38' => 'Buy 3 or more, get $0.30 off',
'39' => '$0.39',
'40' => '$0.40',
'41' => 'Buy 3 or more, get $0.50 off',
'42' => 'Buy 3 or more, get $1.00 off',
'43' => 'Buy 2 or more, get $1.10 off',
'44' => 'Buy 2 or more, get $1.35 off',
'45' => '$0.45',
'46' => 'Buy 2 or more, get $1.60 off',
'47' => 'Buy 2 or more, get $1.75 off',
'48' => 'Buy 2 or more, get $1.85 off',
'49' => '$0.49',
'50' => '$0.50',
'51' => 'Buy 2 or more, get $2.00 off',
'52' => 'Buy 3 or more, get $0.55 off',
'53' => 'Buy 2 or more, get $0.10 off',
'54' => 'Buy 2 or more, get $0.15 off',
'55' => '$0.55',
'56' => 'Buy 2 or more, get $0.20 off',
'57' => 'Buy 2, get $0.25 off',
'58' => 'Buy 2, get $0.30 off',
'59' => '$0.59',
'60' => '$0.60',
'61' => '$10.00',
'62' => '$9.50',
'63' => '$9.00',
'64' => '$8.50',
'65' => '$0.65',
'66' => '$8.00',
'67' => '$7.50',
'68' => '$7.00',
'69' => '$0.69',
'70' => '$0.70',
'71' => '$6.50',
'72' => '$6.00',
'73' => '$5.50',
'74' => '$5.00',
'75' => '$0.75',
'76' => '$1.00',
'77' => '$1.25',
'78' => '$1.50',
'79' => '$0.79',
'80' => '$0.80',
'81' => '$1.75',
'82' => '$2.00',
'83' => '$2.25',
'84' => '$2.50',
'85' => '$0.85',
'86' => '$2.75',
'87' => '$3.00',
'88' => '$3.25',
'89' => '$0.89',
'90' => '$0.90',
'91' => '$3.50',
'92' => '$3.75',
'93' => '$4.00',
'94' => '$4.25',
'95' => '$0.95',
'96' => '$4.50',
'97' => '$4.75',
'98' => 'Buy 2 or more, get $0.65 off',
'99' => '$0.99',
);
}
# Autoload methods go after =cut, and are processed by the autosplit program.
1;
__END__
# documentation:
=head1 NAME
Business::UPC - Perl extension for manipulating Universal Product Codes
=head1 SYNOPSIS
use Business::UPC;
# Constructors:
# create a UPC object using standard (type-A) UPC
$upc = new Business::UPC('012345678905');
# create a UPC object using zero-supressed (type-E) UPC
$upc = type_e Business::UPC('01201303');
# is the UPC valid (correct check digit)?
$upc->is_valid;
# correct the check digit
$upc->fix_check_digit;
# get the numeric string:
$upc->as_upc; # same as $upc->as_upc_a;
$upc->as_upc_a;
$upc->as_upc_e;
# get the components;
$upc->number_system; # UPC number system character
$upc->mfr_id; # Manufacturer ID
$upc->prod_id; # Product ID
$upc->check_digit; # Check Digit
# more information about the components:
$upc->number_system_description # explain number_system
# methods specific to coupon UPC codes:
$upc->is_coupon;
$upc->coupon_family_code; # 3-digit family code
$upc->coupon_family_description; # explain above
$upc->coupon_value_code; # 2-digit value code
$upc->coupon_value; # explain above
=head1 DESCRIPTION
More detail to come later...
=head1 AUTHOR
Rob Fugina, robf@geeks.com
=head1 SEE ALSO
perl(1).
=cut