in reply to Pulling data out of { }

my %data;

{
   my $in = 0;
   my %rec;

   while (<DATA>) {
      if (/^\s*{/) {
         $in = 1;
         next;
      }

      if (/^\s*}/) {
         my $name = delete($rec{Name});
         $data{$name} = { %rec };
         undef %rec;

         $in = 0;
         next;
      }

      if ($in) {
         if (/^\s*(\S+)\s*=\s*"(.*)"/) {
            $rec{$1} = $2;
         }
      }
   }
}

require Data::Dumper;
print(Data::Dumper::Dumper(\%data));

[download]

outputs 

$VAR1 = {
          'C:' => {
                    'Size' => '160031014912',
                    'FreeSpace' => '114151464960'
                  },
          'D:' => {
                    'Size' => '203921108992',
                    'FreeSpace' => '5515554816'
                  },
          'H:' => {
                    'Size' => '400086708224',
                    'FreeSpace' => '43128733696'
                  }
        };

[download]

You could also use the .. operator: 

my %data;

{
   my %rec;

   while (<DATA>) {
      if (/^\s*{/ .. /^\s*}/) {

         if (/^\s*{/) {
            next;
         }

         if (/^\s*}/) {
            my $name = delete($rec{Name});
            $data{$name} = { %rec };
            undef %rec;

            next;
         }

         if (/^\s*(\S+)\s*=\s*"(.*)"/) {
            $rec{$1} = $2;
         }
      }
   }
}

require Data::Dumper;
print(Data::Dumper::Dumper(\%data));

[download]

Replies are listed 'Best First'.
Re^2: Pulling data out of { }
by ikegami (Patriarch) on Jan 15, 2006 at 06:58 UTC
    Or you could avoid ifs and whiles completely: 
    use strict;
use warnings;

use Parse::RecDescent ();

my $grammar = <<'__END_OF_GRAMMAR__';

{
   use strict;
   use warnings;

   sub dequote {
      local $_ = @_ ? $_[0] : $_;
      s/^"//;
      s/"$//;
      s/\\(.)/$1/sg;
      return $_;
   }
}

parse   : record(s?) /\Z/
          { [ map @$_, @{$item[1]} ] }

record  : 'instance' 'of' 'Win32_LogicalDisk' '{' field(s?) '}' ';'
          {
             my $name;
             my %record;

             %record = map @$_, @{$item[5]};
             $name = delete($record{Name});
             
             $name ? [ $name, \%record ] : undef
          }

field   : key '=' val ';'
          { [ $item[1], $item[3] ] }

key     : IDENT
val     : QSTRING

IDENT   : /\w+/
QSTRING : /"(?:[^\\"]|\\.)*"/ { dequote($item[1]) }  # guessing.

__END_OF_GRAMMAR__

my $p = Parse::RecDescent->new($grammar)
or die("Bad grammar\n");

my $text; { local $/; $text = <DATA>; }

my $data = $p->parse($text)
or die("Bad data\n");

require Data::Dumper;
print(Data::Dumper::Dumper($data));

    [download]

    Same output as the program in the parent post.

[reply]
[d/l]
[select]

      Out of interest, are you doing something unusual here that makes this grammer run so slowly?

      For example, is your dequote sub being eval'd into existance every time it is used or something similar?

      Also, is there any particular benefit in doing 

      require Data::Dumper;
print(Data::Dumper::Dumper($data));

      [download]

      Instead of the usual use Data::Dumper/print Dumper $data?

      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      Lingua non convalesco, consenesco et abolesco. -- Rule 1 has a caveat! -- Who broke the cabal?
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
[d/l]
[select]

        The sub is only eval'ed once per new.

        I bet it (->parse) doesn't run slowly. The time is probably spent parsing the grammar, compiling it into Perl code, and compiling the Perl code (->new). Parse::RecDescent shouldn't be used directly in production code. Modules created by Parse::RecDescent's Precompile method should be used instead.

        There is no benefit to using require here. I don't like to use use at spots other than at the top of the package, and I wanted to group the testing code together.

[reply]
[d/l]
[select]

In Section Seekers of Perl Wisdom