Perl: перебрать глобус - PullRequest
Новая
       24

Perl: перебрать глобус

5 голосов
/ 03 августа 2010

С учетом typeglob, как я могу найти, какие типы на самом деле определены?

В моем приложении мы используем PERL как простой формат конфигурации.Я хотел бы потребовать () пользовательский конфигурационный файл, а затем иметь возможность видеть, какие переменные определены, а также какие они типы.

Код: (сомнительные рекомендации по качеству) 

#!/usr/bin/env perl

use strict;
use warnings;

my %before = %main::;
require "/path/to/my.config";
my %after = %main::;

foreach my $key (sort keys %after) {
    next if exists $before{$symbol}; 

    local *myglob = $after{$symbol};
    #the SCALAR glob is always defined, so we check the value instead
    if ( defined ${ *myglob{SCALAR} } ) {
        my $val = ${ *myglob{SCALAR} };
        print "\$$symbol = '".$val."'\n" ;
    }
    if ( defined *myglob{ARRAY} ) {
        my @val = @{ *myglob{ARRAY} };
        print "\@$symbol = ( '". join("', '", @val) . "' )\n" ;
    }
    if ( defined *myglob{HASH} ) {
        my %val = %{ *myglob{HASH} };
        print "\%$symbol = ( ";
        while(  my ($key, $val) = each %val )  {
            print "$key=>'$val', ";
        }
        print ")\n" ;
    }
}

my.config: 

@A = ( a, b, c );
%B = ( b=>'bee' );
$C = 'see';

вывод: 

@A = ( 'a', 'b', 'c' )
%B = ( b=>'bee', )
$C = 'see'
$_<my.config = 'my.config'

Ответы [ 7 ]

7 голосов
/ 03 августа 2010

В общем случае вы не можете делать то, что хотите, благодаря следующей выдержке из perlref :

*foo{THING} возвращает undef, если эта конкретная вещь еще не использовалась, за исключением скаляров. *foo{SCALAR} возвращает ссылку на анонимный скаляр, если $foo еще не использовался. Это может измениться в будущем выпуске.

Но если вы готовы принять ограничение, что любой скаляр должен иметь определенное значение для обнаружения, тогда вы можете использовать код, такой как 

#! /usr/bin/perl

use strict;
use warnings;

open my $fh, "<", \$_;  # get DynaLoader out of the way

my %before = %main::;
require "my.config";
my %after = %main::;

foreach my $name (sort keys %after) {
  unless (exists $before{$name}) {
    no strict 'refs';
    my $glob = $after{$name};
    print "\$$name\n"             if defined ${ *{$glob}{SCALAR} };
    print "\@$name\n"             if defined    *{$glob}{ARRAY};
    print "%$name\n"              if defined    *{$glob}{HASH};
    print "&$name\n"              if defined    *{$glob}{CODE};
    print "$name (format)\n"      if defined    *{$glob}{FORMAT};
    print "$name (filehandle)\n"  if defined    *{$glob}{IO};
  }
}

доставит вас туда.

С my.config из 

$JACKPOT = 3_756_788;
$YOU_CANT_SEE_ME = undef;

@OPTIONS = qw/ apple cherries bar orange lemon /;

%CREDITS = (1 => 1, 5 => 6, 10 => 15);

sub is_jackpot {
  local $" = ""; # " fix Stack Overflow highlighting
  "@_[0,1,2]" eq "barbarbar";
}

open FH, "<", \$JACKPOT;

format WinMessage =
You win!
.

вывод 

%CREDITS
FH (filehandle)
$JACKPOT
@OPTIONS
WinMessage (format)
&is_jackpot

Печать имен требует небольшой работы, но мы можем использовать модуль Data::Dumper, чтобы взять на себя часть нагрузки. Фасад похож на 

#! /usr/bin/perl

use warnings;
use strict;

use Data::Dumper;
sub _dump {
  my($ref) = @_;
  local $Data::Dumper::Indent = 0;
  local $Data::Dumper::Terse  = 1;
  scalar Dumper $ref;
}

open my $fh, "<", \$_;  # get DynaLoader out of the way

my %before = %main::;
require "my.config";
my %after = %main::;

Нам нужно вывести различные слоты немного по-разному, и в каждом случае удалить атрибуты ссылок: 

my %dump = (
  SCALAR => sub {
    my($ref,$name) = @_;
    return unless defined $$ref;
    "\$$name = " . substr _dump($ref), 1;
  },

  ARRAY => sub {
    my($ref,$name) = @_;
    return unless defined $ref;
    for ("\@$name = " . _dump $ref) {
      s/= \[/= (/;
      s/\]$/)/;
      return $_;
    }
  },

  HASH => sub {
    my($ref,$name) = @_;
    return unless defined $ref;
    for ("%$name = " . _dump $ref) {
      s/= \{/= (/;
      s/\}$/)/;
      return $_;
    }
  },
);

Наконец, мы перебираем разность множеств между %before и %after: 

foreach my $name (sort keys %after) {
  unless (exists $before{$name}) {
    no strict 'refs';
    my $glob = $after{$name};
    foreach my $slot (keys %dump) {
      my $var = $dump{$slot}(*{$glob}{$slot},$name);
      print $var, "\n" if defined $var;
    }
  }
}

Используя my.config из вашего вопроса, вы получите 

$ ./prog.pl 
@A = ('a','b','c')
%B = ('b' => 'bee')
$C = 'see'
3 голосов
/ 03 августа 2010

Рабочий код с использованием CPAN-модуля, который устраняет некоторые проблемы, Package :: Stash .Как отмечалось в моем комментарии к ответу gbacon, это означает, что конфигурационный файл не выполняет $someval = undef, но это кажется неизбежным, и по крайней мере другие случаи обнаруживаются.Он также ограничивается типами SCALAR, ARRAY, HASH, CODE и IO - получение GLOB и FORMAT возможно, но делает код менее привлекательным, а также создает шум в выводе:) 

#!perl

use strict;
use warnings;

use Package::Stash;

sub all_vars_in {
  my ($package) = @_;
  my @ret;

  my $stash = Package::Stash->new($package);
  for my $sym ($stash->list_all_package_symbols) {
    for my $sigil (qw($ @ % &), '') {
          my $fullsym = "$sigil$sym";
      push @ret, $fullsym if $stash->has_package_symbol($fullsym);
    }
  }
  @ret;
}

my %before;
$before{$_} ++ for all_vars_in('main');

require "my.config";

for my $var (all_vars_in('main')) {
  print "$var\n" unless exists $before{$var};
}
3 голосов
/ 03 августа 2010

Начиная с 5.010, вы можете различить, существует ли СКАЛЯР, используя модуль самоанализа B;см. Определение объявленных переменных пакета в perl

Обновление: пример, скопированный из этого ответа: 

# package main;
our $f;
sub f {}
sub g {}

use B;
use 5.010;
if ( ${ B::svref_2object(\*f)->SV } ) {
    say "f: Thar be a scalar tharrr!";
}
if ( ${ B::svref_2object(\*g)->SV } ) {
    say "g: Thar be a scalar tharrr!";
}

1;
1 голос
/ 05 апреля 2011 
no strict 'refs';
my $func_name = 'myfunc';
*{$func_name}{CODE}()
use strict 'refs';
1 голос
/ 03 августа 2010

Ненавижу спрашивать, но вместо того, чтобы возиться с typeglobs, почему бы не перейти на реальный формат конфигурации? например проверить Config :: Simple и YAML .

Я бы не рекомендовал возиться с типоглобами и таблицами символов в обычных случаях (некоторые модули CPAN делают это, но только на нижних уровнях больших систем - например, Moose на самых низких уровнях Class :: MOP). Perl дает вам много веревки для работы, но эта веревка также очень рада самоуничижению и завязыванию вокруг шеи, если вы не будете осторожны:)

См. Также: Как вы управляете файлами конфигурации в Perl?

1 голос
/ 03 августа 2010

UPDATE:
Гбэкон прав. * glob {SCALAR} определен.

Вот вывод, который я получаю, используя ваш код: 

Name "main::glob" used only once:
possible typo at
test_glob_foo_thing.pl line 13. 
'FOO1' (SCALAR)
'FOO1' (GLOB)
'FOO2' (SCALAR)
'FOO2' (GLOB)
'_<my.config' (SCALAR)
'_<my.config' (GLOB)

Это несмотря на то, что FOO2 определяется как хеш, но не как скаляр.

ОРИГИНАЛЬНЫЙ ОТВЕТ:

Если я вас правильно понимаю, вам просто нужно использовать встроенный defined. 

#!/usr/bin/env perl

use strict;
use warnings;

my %before = %main::;
require "/path/to/my.config";
my %after = %main::;

foreach my $key (sort keys %after) {
    if (not exists $before{$key}) {
        if(defined($after{$key}){
             my $val = $after{$key};
             my $what = ref($val);
             print "'$key' ($what)\n";
        }
    }
}
0 голосов
/ 03 августа 2010

Если вы не против разбора выходных данных Data :: Dump, вы можете использовать их для выявления различий. 

use strict;
use warnings;
use Data::Dump qw{ dump };

my %before = %main::;
require "my.config";
my %after = %main::;

foreach my $key ( sort keys %after ) {
    if ( not exists $before{$key} ) {
        my $glob = $after{$key};
        print "'$key' " . dump( $glob) . "\n";
    }
}

Используя этот код со следующим файлом конфигурации: 

$FOO1 = 3;
$FOO2 = 'my_scalar';
%FOO2 = ( a=>'b', c=>'d' );
@FOO3 = ( 1 .. 5);
$FOO4 = [ 1 .. 5 ];

Я полагаю, что этот вывод предоставляет достаточно информации, чтобы определить, какие части каждого типа глобуса определены: 

'FOO1' do {
  my $a = *main::FOO1;
  $a = \3;
  $a;
}
'FOO2' do {
  my $a = *main::FOO2;
  $a = \"my_scalar";
  $a = { a => "b", c => "d" };
  $a;
}
'FOO3' do {
  my $a = *main::FOO3;
  $a = [1 .. 5];
  $a;
}
'FOO4' do {
  my $a = *main::FOO4;
  $a = \[1 .. 5];
  $a;
}
'_<my.config' do {
  my $a = *main::_<my.config;
  $a = \"my.config";
  $a;
}
...