package ATR::Util;

use strict;
use warnings;

use base 'Exporter';
our @EXPORT = qw(safegrep safemap make_args);

# XXX:TEST Not a one of them

=head1 NAME

ATR::Util - minor utility functions

=head1 DESCRIPTION

=head2 safegrep { warn "Testing for $_[0]"; rand(4) E<lt> 1; } @things

Works almost the same as C<grep>, except C<$_> is not aliased to the
input list.  The code block must instead use the first parameter
passed in C<@_> in the usual way.

=head2 safemap { warn "Mapping $_[0]"; $_[0]-E<gt>getWotsit } @stuff

Ditto, for C<map>.

=cut

sub safegrep (&@) {
    my ($code, @list) = @_;
    return grep {
	my $item = $_;
	local $_ = undef; # unalias our object; prevent the user assuming $_ is valid
	$code->($item);
    } @list;
}

sub safemap (&@) {
    my ($code, @list) = @_;
    return map {
	my $item = $_;
	local $_ = undef; # unalias our object; prevent the user assuming $_ is valid
	$code->($item);
    } @list;
}


=head2 make_args(\@given_pairs, \@default_pairs, \@allowed_keys)

A plain subroutine.

@allowed_keys list is optional. XXX: yet unused, subject to change .. use for type checking?

Uses the given args to build a standard args hash.  Takes the default
values and disallows any key which is given but has no default and is
not in the allowed keys list.

Returns a list of hash members (in list context) or a hashref
containing these members (in scalar context).

=cut

sub make_args {
    my ($given, $default, $allowed) = @_;
    $allowed ||= [];

    die "Odd number of items in key/value list of given arguments" if (@$given) % 2;
    die "Odd number of items in key/value list of defaults" if (@$default) % 2;

    my %default = @$default;
    my %given = @$given;

    my %out = %default;
    foreach my $key (@$allowed, keys %default) {
	next unless exists $given{$key};
	$out{$key} = delete $given{$key};
    }

    my @left = sort keys %given;
    die "Unknown arguments (@left) given" if @left;

    return wantarray ? %out : \%out;
}


=head2 rand_colour()

Return a string suitable for use as a Tk colour.

=cut

sub rand_colour { sprintf("#%02x%02x%02x", rand(255), rand(255), rand(255)) }


=head2 tlBalloon($widget)

Get a L<Tk::Balloon> for the widget's toplevel.  (Creating new ones is
slightly slow and inefficient.)

=cut

sub tlBalloon {
    my $widget = shift;
    my $tl = $widget->toplevel;
    return $tl->privateData->{balloon} ||= $tl->Balloon;
}


package ATR::Util::ScopeHelper;

sub new {
    my ($proto, $code) = @_;
    return bless \$code, ref($proto) || $proto;
}

sub DESTROY {
    my $self = shift;
    $$self->();
}

1;
