[Summary view] [Print] [Text view]

   1  # Object to represent a .ini file.  Includes methods for parsing and
   2  # generating.
   3  
   4  package Unattend::IniFile;
   5  
   6  use warnings;
   7  use strict;
   8  use Carp;
   9  use Tie::RefHash;
  10  
  11  # We cannot "use fields" here because we want to overload the hash
  12  # dereference operator.  So, we use an array as our representation,
  13  # and constants to refer to the slots in the array.
  14  use constant SECTIONS => 0;
  15  use constant COMMENTS => 1;
  16  use constant SECTION_COMMENTS => 2;
  17  use constant SORT_INDEX => 3;
  18  use constant SECTION_SORT_INDEX => 4;
  19  
  20  # Overload hash dereference.  Return "sections" hash, which is the
  21  # interesting part.
  22  use overload
  23      '%{}' => sub { my ($self) = @_;
  24                     return $self->[SECTIONS];
  25                 };
  26  
  27  use constant NO_VAL_REF => [ 'Magic no_val string' ];
  28  
  29  # Constructor.  Arguments, if provided, will be passed to "read".
  30  sub new ($;@) {
  31      my ($proto, @read_args) = @_;
  32      my $class = ref $proto || $proto;
  33  
  34      my $self = [ ];
  35  
  36      # Initialize all of our slots with hashes.
  37      tie %{$self->[SECTIONS]}, 'Unattend::IniFile::_Hash';
  38      tie %{$self->[COMMENTS]}, 'Unattend::IniFile::_Hash';
  39      tie %{$self->[SECTION_COMMENTS]}, 'Unattend::IniFile::_Hash';
  40      tie %{$self->[SORT_INDEX]}, 'Unattend::IniFile::_Hash';
  41      tie %{$self->[SECTION_SORT_INDEX]}, 'Unattend::IniFile::_Hash';
  42  
  43      bless $self, $class;
  44  
  45      scalar @read_args > 0
  46          and $self->read (@read_args);
  47      return $self;
  48  }
  49  
  50  # Return the "unforced" value for a section or section+key.  This will
  51  # either be the actual value, or a Promise which can be "forced" to
  52  # deliver the value.
  53  sub noforce ($$;$) {
  54      my ($self, $section, $key) = @_;
  55  
  56      if (defined $key) {
  57          my $sec_hash = $self->{$section};
  58          return (tied %$sec_hash)->fetch_noforce ($key);
  59      }
  60      else {
  61          return (tied %$self)->fetch_noforce ($section);
  62      }
  63  }
  64  
  65  # Return true if argument (returned by noforce) is a promise.
  66  sub is_promise ($) {
  67      my ($arg) = @_;
  68      return ref $arg eq 'Unattend::Promise';
  69  }
  70  
  71  # Helper hash to detect recursive forcing of promises.
  72  my %recursion_detect;
  73  tie %recursion_detect, 'Tie::RefHash';
  74  
  75  # Force a value returned by noforce.  Also detect recursive loops, to
  76  # return undef when they happen.
  77  sub force ($) {
  78      my ($value) = @_;
  79  
  80      if (is_promise ($value)) {
  81          if ($recursion_detect{$value}) {
  82              # We are in the process of evaluating this promise, so cause
  83              # the recursion to "bottom out" by returning undef.
  84              $value = undef;
  85  
  86          }
  87          else {
  88              # Remember we were here so that we can detect loops.
  89              local $recursion_detect{$value} = 1;
  90              $value = $value->force ();
  91          }
  92      }
  93  
  94      return $value;
  95  }
  96  
  97  # This is garbage.  Clean it up!  (FIXME)
  98  sub push_value ($$$$) {
  99      my ($self, $section, $key, $value) = @_;
 100  
 101      my $orig_value = $self->noforce ($section, $key);
 102  
 103      # Convert value into a Promise
 104      $self->{$section}->{$key} = $value;
 105      $value = $self->noforce ($section, $key);
 106  
 107      # Install a new Promise which does the "right thing".
 108      $self->{$section}->{$key} =
 109           sub {
 110               my $forced = force ($value);
 111               return (defined $forced ? $forced : force ($orig_value));
 112           };
 113  
 114      return 1;
 115  }
 116  
 117  # Return the magic scalar representing "no value".
 118  sub no_value ($) {
 119      my ($self) = @_;
 120      return NO_VAL_REF;
 121  }
 122  
 123  # Get the (modifiable) comments field for a section or section+key.
 124  sub comments : lvalue {
 125      my ($self, $section, $key) = @_;
 126  
 127      my $ref = (defined $key
 128                 ? \$self->[COMMENTS]->{$section}->{$key}
 129                 : \$self->[SECTION_COMMENTS]->{$section});
 130  
 131      defined $$ref
 132          or $$ref = [ ];
 133  
 134      $$ref;
 135  }
 136  
 137  # Convert comments for a section or section+key into canonical form
 138  # (array of lines).
 139  sub _canonicalize_comments ($) {
 140      my ($comments) = @_;
 141  
 142      defined $comments
 143          or $comments = [ ];
 144  
 145      ref $comments
 146          and return $comments;
 147  
 148      return [ split /\n/, $comments ];
 149  }
 150  
 151  # Get the (modifiable) sort index for a section or section+key.
 152  sub sort_index : lvalue {
 153      my ($self, $section, $key) = @_;
 154  
 155      my $ref = (defined $key
 156                 ? \$self->[SORT_INDEX]->{$section}->{$key}
 157                 : \$self->[SECTION_SORT_INDEX]->{$section});
 158      defined $$ref
 159          or $$ref = -1;
 160      $$ref;
 161  }
 162  
 163  # Return the largest sort index of any section or section+key pair,
 164  # but without "forcing" any sections.
 165  sub max_index ($) {
 166      my ($self) = @_;
 167      my $ret = 0;
 168  
 169      foreach my $section (keys %{$self}) {
 170          my $index = $self->sort_index ($section);
 171          $ret < $index
 172              and $ret = $index;
 173          my $sec_hash = $self->noforce ($section);
 174  
 175          defined $sec_hash && !is_promise ($sec_hash)
 176              or next;
 177  
 178          foreach my $key (keys %{$sec_hash}) {
 179              $index = $self->sort_index ($section, $key);
 180              $ret < $index
 181                  and $ret = $index;
 182          }
 183      }
 184  
 185      return $ret;
 186  }
 187  
 188  # Helper function for merging comments.
 189  sub _merge_comments ($$) {
 190      my ($c1, $c2) = @_;
 191  
 192      $c1 = _canonicalize_comments ($c1);
 193      $c2 = _canonicalize_comments ($c2);
 194  
 195      # If the new comments are non-trivial or the old comments are
 196      # trivial, return the new.
 197      return ((0 < scalar grep { /[^\s;]/ } @$c2
 198               || 0 == scalar grep { /[^\s;]/ } @$c1)
 199              ? $c2
 200              : $c1);
 201  }
 202  
 203  # Merge another IniFile into ourselves.
 204  sub merge ($$) {
 205      my ($self, $other) = @_;
 206  
 207      my $other_max_index = $other->max_index ();
 208  
 209      # Offset our sort indices so that we will sort after other
 210      foreach my $section (keys %{$self}) {
 211          $self->sort_index ($section) += $other_max_index;
 212          # Too much duplicated code!  FIXME
 213          my $sec_hash = $self->noforce ($section);
 214          defined $sec_hash && !is_promise ($sec_hash)
 215              or next;
 216          foreach my $key (keys %{$sec_hash}) {
 217              $self->sort_index ($section, $key) += $other_max_index;
 218          }
 219      }
 220  
 221      foreach my $section (keys %{$other}) {
 222          # BIG HACK FIXME FIXME FIXME
 223          is_promise ($self->noforce ($section))
 224              and $self->{$section} = { };
 225          # Merge the section comments.
 226          $self->comments ($section) =
 227              _merge_comments ($self->comments ($section),
 228                               $other->comments ($section));
 229          # Overwrite the section sort index.
 230          $self->sort_index ($section) = $other->sort_index ($section);
 231          foreach my $key (keys %{$other->{$section}}) {
 232              # Copy the value.
 233              $self->{$section}->{$key} = $other->{$section}->{$key};
 234              # Merge the comments.
 235              $self->comments ($section, $key) =
 236                  _merge_comments ($self->comments ($section, $key),
 237                                   $other->comments ($section, $key));
 238              # Overwrite the sort index.
 239              $self->sort_index ($section, $key) =
 240                  $other->sort_index ($section, $key);
 241          }
 242      }
 243  
 244      return 1;
 245  }
 246  
 247  # Characters needing no quotes on output
 248  my $nq_out_chars = qr{[a-zA-Z0-9_.,<>:/~%*\-\\\$]};
 249  # Characters needing no quotes on input
 250  my $nq_in_chars = qr{(?:$nq_out_chars|[() \x80-\xFF])};
 251  
 252  # Regexp matching a single token (key or value)
 253  my $token = qr{(?:\".*?\"|$nq_in_chars+?)};
 254  
 255  # Read a .ini file and merge its contents into ourselves.  Second
 256  # argument, if present, is a regexp; sections whose names do not match
 257  # will be skipped (useful optimization when only examining part of a
 258  # large file).
 259  sub read ($$;$) {
 260      my ($self, $file, $sect_pattern) = @_;
 261      my $section;
 262      my $comments = [ ];
 263  
 264      my $sect_re = (defined $sect_pattern
 265                     ? qr{^(?:$sect_pattern)\z}i
 266                     : qr{.?});
 267  
 268      my $acc = new ref $self;
 269  
 270      open FILE, $file
 271          or die "Unable to open $file: $^E";
 272  
 273      while (my $line = <FILE>) {
 274          chomp $line;
 275          # Clobber CR (for testing on Unix).
 276          $line =~ s/\r//;
 277          # Remove leading and trailing whitespace.
 278          $line =~ s/^\s+//;
 279          $line =~ s/\s+\z//;
 280  
 281          # Skip blank lines
 282          $line =~ /^\z/
 283              and next;
 284  
 285          if ($line =~ /^\[\s*(.+?)\s*\]\z/) {
 286              # New section header
 287              $section = $1;
 288              $section =~ $sect_re
 289                  or next;
 290              my $old_index = $acc->sort_index ($section);
 291  #            $old_index >= 0
 292  #                and (die "Duplicate [$section] sections in $file, ",
 293  #                     "lines $old_index and $.\n");
 294              $old_index < 0
 295                  and $acc->sort_index ($section) = $.;
 296              $acc->comments ($section) = $comments;
 297              $comments = [ ];
 298              # Make sure section exists, even it it contains no values
 299              (exists $acc->{$section})
 300                  or $acc->{$section} = undef;
 301              next;
 302          }
 303          elsif ($line =~ /^([;\#])/) {
 304              # Comment
 305              my $comment = $1;
 306              chomp $comment;
 307              push @$comments, $comment;
 308              next;
 309          }
 310          elsif (defined $section && $section !~ $sect_re) {
 311              # Skip sections which do not match regexp, but accumulate
 312              # comments for sections which do match.
 313              $comments = [ ];
 314              next;
 315          }
 316          elsif ($line =~
 317                 /^($token)\s*(?:=\s*($token\s*(?:,\s*$token\s*)*))?\z/) {
 318              # key=value setting
 319              my ($key, $rest) = ($1, $2);
 320              defined $section
 321                  or die "$key outside any section at $file line $.";
 322  
 323              # Strip quotation marks around key.
 324              $key =~ /^\"(.*)\"$/
 325                  and $key = $1;
 326  
 327              my $val;
 328  
 329              if (defined $rest) {
 330                  my @elts;
 331                  while ($rest =~ /\S/) {
 332                      my $elt;
 333                      ($elt, $rest) = $rest =~ /^($token)\s*(?:,|\z)\s*(.*)/;
 334                      defined $elt
 335                          or die 'Internal error';
 336                      # Strip quotation marks around element.
 337                      $elt =~ /^\"(.*)\"\z/
 338                          and $elt = $1;
 339                      push @elts, $elt;
 340                  }
 341                  scalar @elts > 0
 342                      or die "Internal error";
 343                  $val = (scalar @elts > 1
 344                          ? \@elts :
 345                          $elts[0]);
 346              }
 347              else {
 348                  # No value provided.
 349                  $val = $acc->no_value;
 350              }
 351  
 352              my $old_index = $acc->sort_index ($section, $key);
 353  #            $old_index >= 0
 354  #                and (die "Duplicate $key settings in $file, ",
 355  #                     "lines $old_index and $.\n");
 356              $acc->sort_index ($section, $key) = $.;
 357              $acc->{$section}->{$key} = $val;
 358              $acc->comments ($section, $key) = $comments;
 359              $comments = [ ];
 360              next;
 361          }
 362          
 363          die "Unrecognized line:\n  $line\n...in $file, ";
 364      }
 365  
 366      close FILE
 367          or die "Unable to close $file: $^E";
 368  
 369      return $self->merge ($acc);
 370  }
 371  
 372  # Handy string for indentation.
 373  my $global_indent = '    ';
 374  
 375  # Dump comments for a section or for a section+key pair.
 376  sub _dump_comments ($$;$) {
 377      my ($self, @sect_key) = @_;
 378      my @ret;
 379  
 380      my $indent = $global_indent;
 381      my $comments = _canonicalize_comments ($self->comments (@sect_key));
 382  
 383      if (!exists $sect_key[1]) {
 384          # Section data.
 385          # Do not indent.
 386          $indent = '';
 387          # Precede with a blank line unless one is already present.
 388          exists $comments->[0] && $comments->[0] =~ /^\s*\z/
 389              or unshift @$comments, '';
 390      }
 391  
 392      # Format the comments.  Make sure they are preceeded by the
 393      # comment character.
 394      foreach my $comment (@$comments) {
 395          $comment =~ /^\s*(?:;|\z)/
 396              or $comment = "; $comment";
 397          push @ret, "$indent$comment";
 398      }
 399  
 400      return @ret;
 401  }
 402  
 403  # Put quotes around a string if needed.
 404  sub _maybe_quote ($) {
 405      my ($arg) = @_;
 406  
 407      $arg =~ /^$nq_out_chars+\z/
 408          and return $arg;
 409      return "\"$arg\"";
 410  }
 411  
 412  sub generate ($) {
 413      my ($self) = @_;
 414      my @ret;
 415  
 416      foreach my $section (sort { $self->sort_index ($a)
 417                                      <=> $self->sort_index ($b) }
 418                           keys %{$self}) {
 419          (defined $self->{$section})
 420              or next;
 421          push @ret, $self->_dump_comments ($section);
 422          push @ret, "[$section]";
 423          foreach my $key (sort { $self->sort_index ($section, $a)
 424                                      <=> $self->sort_index ($section, $b) }
 425                           keys %{$self->{$section}}) {
 426              my $value = $self->{$section}->{$key};
 427              defined $value
 428                  or next;
 429              push @ret, $self->_dump_comments ($section, $key);
 430              $key = _maybe_quote ($key);
 431              if (ref $value && $value == $self->no_value) {
 432                  push @ret, "$global_indent$key";
 433              }
 434              else {
 435                  # Convert value to a string.
 436                  my @elts = (ref $value eq 'ARRAY'
 437                              ? @$value
 438                              : ($value));
 439                  my $string = join ',', map { _maybe_quote ($_) } @elts;
 440                  push @ret, "$global_indent$key = $string";
 441              }
 442          }
 443      }
 444  
 445      # Strip leading blank lines
 446      while (0 < scalar @ret && $ret[0] =~ /^\s*\z/) {
 447          shift @ret;
 448      }
 449  
 450      return @ret;
 451  }
 452  
 453  # Special magical hash.  When a proc is stored, we convert it into a
 454  # Promise and store that instead.  When fetched, the Promise is
 455  # forced.
 456  
 457  package Unattend::IniFile::_Hash;
 458  use Unattend::FoldHash;
 459  use base qw(Unattend::FoldHash::Nestable);
 460  use Unattend::Promise;
 461  
 462  sub STORE ($$$) {
 463      my ($self, $key, $value) = @_;
 464  
 465      my $new_value = (ref $value eq 'CODE'
 466                       ? Unattend::Promise->new ($value)
 467                       : $value);
 468  
 469      return $self->SUPER::STORE ($key, $new_value);
 470  }
 471  
 472  sub FETCH ($$) {
 473      my ($self, $key) = @_;
 474  
 475      my $value = $self->SUPER::FETCH ($key);
 476  
 477      if (Unattend::IniFile::is_promise ($value)) {
 478          # Store it back to automatically convert hashes to FoldHashes.
 479          $self->SUPER::STORE ($key, Unattend::IniFile::force ($value));
 480      }
 481  
 482      return $self->SUPER::FETCH ($key);
 483  }
 484  
 485  sub fetch_noforce ($$) {
 486      my ($self, $key) = @_;
 487  
 488      return $self->SUPER::FETCH ($key);
 489  }
 490  
 491  1;