Device::Cdio::Util - Internal utilities used by Cdio modules

package Device::Cdio::Util;
require 5.8.6;
#
#    $Id: Util.pm,v 1.7 2006/03/17 03:35:32 rocky Exp $
#
#    Copyright (C) 2006 Rocky Bernstein <rocky@cpan.org>
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

# These are internal routines. Not all that useful for external consumption.

use strict;
use vars qw($VERSION @EXPORT_OK @ISA );
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(_rearrange _make_attributes _check_arg_count _extra_args);

$VERSION = $Device::Cdio::VERSION;

# Check that we $count (the argument count of arguments passed has
# between $min and $max arguments.
sub _check_arg_count {
    my ($count, $min, $max) = @_;
    my $msg = undef;
    if (!defined($max)) {
	if ($count != $min) {
	    $msg = sprintf("Need to supply exactly %d arguments. (got %d)",
			   $min, $count);
	}
    } elsif ($count < $min) {
	$msg = sprintf("Need to supply at least %d arguments. (got %d)",
		       $min, $count);
    } elsif ($count > $max) {
	$msg = sprintf("Need to supply no more than %d arguments. (got %d)",
		       $max, $count);
    }
    if (defined($msg)) {
	my (undef, $file, $line, $called)= caller(1);
	print "$msg.\n\tCalled $called from file $file at line $line\n";
	return 0;
    }
    return 1;
}

# Check that we $count (the argument count of arguments passed has
# between $min and $max arguments.
sub _extra_args {
    my @args = @_;
    if (@args != 0) {
	my (undef, $file, $line, $called)= caller(1);
	my $arg_count = @args;
	print "$arg_count extraneous parameter given in call\n";
	print "\tCalled $called from file $file at line $line\n";
	return 1;
    }
    return 0;
}

# Taken from CGI::Util
sub _make_attributes {
    my $attr = shift;
    return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
    my $escape =  shift || 0;
    my(@att);
    foreach (keys %{$attr}) {
	my($key) = $_;
	$key=~s/^\-//;     # get rid of initial - if present

	# old way: breaks EBCDIC!
	# $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes

	($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes

	my $value = $escape ? _simple_escape($attr->{$_}) : $attr->{$_};
	push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
    }
    return @att;
}

# Taken from CGI::Util
# Smart rearrangement of parameters to allow named parameter
# calling.  We do the rearangement if:
# the first parameter begins with a -
sub _rearrange {
    my($order,@param) = @_;
    return () unless @param;

    if (ref($param[0]) eq 'HASH') {
	@param = %{$param[0]};
    } else {
	return @param 
	    unless (defined($param[0]) && substr($param[0],0,1) eq '-' 
		    && $param[0] !~ m{\A-\d+});
    }

    # map parameters into positional indices
    my ($i,%pos);
    $i = 0;
    foreach (@$order) {
	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
	$i++;
    }

    my (@result,%leftover);
    $#result = $#$order;  # preextend
    while (@param) {
	my $key = lc(shift(@param));
	$key =~ s/^\-//;
	if (exists $pos{$key}) {
	    $result[$pos{$key}] = shift(@param);
	} else {
	    $leftover{$key} = shift(@param);
	}
    }

    push (@result,_make_attributes(\%leftover,defined $CGI::Q ? $CGI::Q->{escape} : 1)) if %leftover;
    @result;
}

# Also from CGI::Util.pm
sub _simple_escape {
  return unless defined(my $toencode = shift);
  $toencode =~ s{&}{&amp;}gso;
  $toencode =~ s{<}{&lt;}gso;
  $toencode =~ s{>}{&gt;}gso;
  $toencode =~ s{\"}{&quot;}gso;
# Doesn't work.  Can't work.  forget it.
#  $toencode =~ s{\x8b}{&#139;}gso;
#  $toencode =~ s{\x9b}{&#155;}gso;
  $toencode;
}

1; # Magic true value required at the end of a module

__END__