Discover a package global's symbol name given a reference

[davido]

Earlier today pmneve posted the following question to Seekers of Perl Wisdom: getting the name of a variable to use as string. While ultimately the best solution to that particular question is probably a re-thinking of the script's design, it did get me thinking, and kudos to pmneve for that! ;)

pmneve was asking how to discover a lexical variable's name, given...the variable. That really isn't possible in pure Perl (nor should it be necessary), as lexicals don't live in a symbol table that can be inspected from within a pure Perl script. But package globals do live in a script-accessible symbol table. The code that follows may have no practical use, and should never have been written, but I couldn't resist the challenge of walking the symbol table to find a given variable's name.

The following code snippets consist of two entities. The first should be saved as SymbolName.pm. It is a package that consists of a single subroutine called get_symbol_name(). Hand this subroutine a reference of a package global (of almost any kind), and you'll get back its name as the return value. The second is a script that tests SymbolName.pm. Read on for the caveats...

Now some of you are going to see a few holes here, and I think some of them are insurmountable. The first is that a reference needn't necessarily refer to a named variable. But if you pass it a reference to a package global, that issue is moot; package globals are all named. The second problem is that entities in the global symbol table may be aliased using typeglobs. That means that *foo can be aliased to *bar, meaning that $foo will be just another name for $bar. That has the effect that a given reference may be associated with more than a single symbol in the symbol table. When that happens, you have no way of being sure whether the alias or the original name will be returned. If you have aliased *foo to *bar, and you call get_symbol_name( \$foo ), you may get "foo", or you may get "bar". So sorry, them's the breaks.

To use get_symbol_name(), pass it a reference to a package global, and optionally, a package name. If the package name is main, you can omit the package name and it will be assumed by default. The return value will be the symbol's name. If you pass a reference from a variable that can't be found in the symbol table, the subroutine will complain and die. It will also complain and die if you pass something other than a reference. And it will complain and die if you figure out some way of passing it a reference to a package global that isn't a SCALAR, ARRAY, HASH, GLOB or CODE.

I'm posting this as a meditation because I'm interested in hearing feedback. Keep in mind, I see no practical use for this code, but do see it as an interesting topic. One issue I haven't figured out is the proper syntax for applying a *foo{THING} validity check to each option within the SWITCH block, to verify that the reference passed, and whos name was found in the symbol table, really has a valid THING.

Without further pontification, here's the fiendish code.

First, SymbolName.pm:

package SymbolName;

use strict;
use warnings;

use base qw/ Exporter /;
our @ISA = qw/ Exporter /;
our @EXPORT = qw/ get_symbol_name /;

sub get_symbol_name {
    my( $var_ref, $pkg ) = @_;
    $pkg |= 'main';
    $pkg .= '::';
    my $type = ref $var_ref;
    foreach my $key ( keys %:: ) {
        my $table_ref;
        SWITCH: {
            no strict qw/ refs /;
            ! $type 
                and die  "Must pass get_symbol_name() a global "
                       . "variable ref.\n";                       
            $type =~ /SCALAR/ && do {
                $table_ref = \${${$pkg}{$key}};
                last SWITCH;
            };
            $type =~/ARRAY/ && do {
                $table_ref = \@{${$pkg}{$key}};
                last SWITCH;
            };
            $type =~/HASH/ && do {
                $table_ref = \%{${$pkg}{$key}};
                last SWITCH;
            };
            $type =~ /CODE/ && do {
                $table_ref = \&{${$pkg}{$key}};
                last SWITCH;
            };
            $type =~ /GLOB/ && do {
                $table_ref = \${$pkg}{$key};
                last SWITCH;
            };
            die "Unsupported type: $type\n";
        }
        
        return $key if $var_ref eq $table_ref
    }
    die "Variable ref $var_ref not found in $pkg\'s symbol table.\n";
}

1;

And now a little script to test it...

use strict;
use warnings;

use SymbolName qw/ get_symbol_name /;

# Set up some symbol names to find.

our $scalar_name = 100;
our %hash_name = ();
our @array_name = ();
*glob_name = 0;
sub subroutine_name { }

# Print the names of each of our new variables.


print "Symbol names found:\n";
foreach my $v_ref (    \(    $scalar_name, 
                             %hash_name, 
                             @array_name, 
                             *glob_name, 
                             &subroutine_name,
                        )  )  {
    print "\t", get_symbol_name( $v_ref, __PACKAGE__ ), "\n";
}

Comments welcomed!

[broquaint]

The switch code hurt my eyes somewhat so I simplified the glob look up code while keeping within the bounds of those ever handy strictures

use strict;

our %TYPES = qw/ SCALAR $ ARRAY @ HASH % CODE & GLOB * IO * /;
sub get_ref_name {
  my $ref  = shift;
  my @pkgs = split '::', scalar( shift || caller );
  my $tbl  = \%main::;

  $tbl = $tbl->{"$_\::"}
    for @pkgs;
  
  my @names;
  for my $n ( keys %$tbl ) {
    push @names, map  [ $TYPES{$_}, $n ],
                 grep $ref == *{ $tbl->{$n} }{$_}, keys %TYPES;
    push @names, [ $TYPES{GLOB}, $n ]
      if $ref == \$tbl->{$n};
  }

  return map $_->[0].join('::', @pkgs, $_->[1]), @names;
}

our $foo;
our @bar;
our %baz;
*quux = \$foo;

print join(', ', get_ref_name($_)), "\n"
  for \( $foo, @bar, %baz ), \&get_ref_name;

__output__

$main::quux, $main::foo
@main::bar
%main::baz
*main::wurble
&main::get_ref_name

And that whole method can probably be done away with some B style magic.

[itub]

Perhaps an interesting option would be to use the caller instead of main as the default package?

[Anonymous Monk]

Symbol::qualify

[chanio]

It worked but not with that '\(', the compiler thinks that I am not starting a real '(' (I guess).

So I put a \ in front of every variable to pass.

Sorry, might have been a mistake or something that I have copied incorrectly. I have downloaded the code again and it now works as you stated. All ok!

Sorry again!

[davido]

What version of Perl are you using? Current Perl (and at least going back a few versions), the \ operator is distributed over lists, so that \( $item1, $item2 ) is the same as ( \$item1, \$item2 ). I wrote this using Perl 5.8.4.

What error message did you get?