#!/usr/bin/perl -w
use strict;

sub is_constant {
    no strict 'refs';
    my $name = shift;
    my $code = *{$name}{CODE};

    # must have an empty prototype to be a constnat
    my $proto = prototype($name);
    return 0 unless defined $proto and not length $proto;

    # attempt to redefine - this will cause a warning for a
    # real constant that starts with "Constant"
    my $is_constant;
    local $SIG{__WARN__} = sub { $is_constant = 1 if $_[0] =~ /^Constant/ };
    eval { *{$name} = sub { "TEST" } };

    # set it back
    eval { *{$name} = $code; };

    # all done
    return $is_constant;
}

use Test::More tests => 6;

use constant CONSTANT1 => 1;
use constant CONSTANT2 => [ 'foo', 'bar' ];
sub CONSTANT3 () { '...' }

sub NONCONSTANT1 () { $_[0]++ }
sub NONCONSTANT2 ($) { "fooey" }
sub NONCONSTANT3 { 1; }

ok(is_constant("main::CONSTANT1"));
ok(is_constant("main::CONSTANT2"));
ok(is_constant("main::CONSTANT3"));
ok(!is_constant("main::NONCONSTANT1"));
ok(!is_constant("main::NONCONSTANT2"));
ok(!is_constant("main::NONCONSTANT3"));