view release on metacpan or  search on metacpan

script/cwb-regedit  view on Meta::CPAN

      print $reg->name if $cmd eq "name";
      print $reg->info if $cmd eq "ifile";
      print $reg->filename if $cmd eq "reg";
      print "\n";
    }
  }
  elsif ($COMMAND eq ":prop") {
    die "Syntax error: no property given for :prop command\n"
      unless @ARGS > 0;
    die "Syntax error: :prop command takes 1 or 2 arguments\n"
      if @ARGS > 2;
    my $p = shift @ARGS;
    if (@ARGS) {
      $reg->property($p, shift @ARGS);
      $CHANGES++;
    }
    else {
      my $value = $reg->property($p);
      if (not defined $value) {
        warn "Corpus property '$p' not defined in registry entry.\n";
        $value = "";
      }
      print "$value\n";
    }
  }
  elsif ($COMMAND eq ":add") {  # add attribute(s)
    die "Syntax error: :add command must be followed by :p, :s or :a\n"
      unless @ARGS == 0 and match_command() =~ /^:[psa]$/;
    while (match_command() =~ /^:([psa])$/) {
      get_block();
      die "Syntax error: arguments missing for :add $COMMAND\n"
        unless @ARGS > 0;
      add_attributes($1, @ARGS);
      $CHANGES++;
    }
  }
  elsif ($COMMAND eq ":del") {  # delete attribute(s)
    die "Syntax error: arguments missing for :del\n"
      unless @ARGS > 0;
    delete_attributes(@ARGS);
    $CHANGES++;
  }
  elsif ($COMMAND eq ":list") { # list attributes of specified type
    die "Syntax error: :list command must be followed by :p, :s or :a\n"
      unless @ARGS == 0 and match_command() =~ /^:[psa]$/;
    while (match_command() =~ /^:([psa])$/) {
      get_block();
      die "Syntax error: no arguments allowed for :list $COMMAND\n"
        unless @ARGS == 0;
      list_attributes($1);
    }
  }
  else {
    die "Command $COMMAND is not valid at this point. Aborted.\n";
  }
}

## write back if any changes have been made
if ($CHANGES > 0) {
  my $regfile = $reg->filename;
  # make a backup first
  system "cp", "-p", $regfile, "$regfile~"; # ignore errors (e.g. if we don't have permissions to make a copy)
  $reg->write;
  print "Changes saved to ", $reg->filename, "\n";
}


##
##  subroutines
##

## delete specified attributes (all of them must exist)
sub delete_attributes {
  my @atts = @_;
  my @missing = grep {not defined $reg->attribute($_)} @atts;
  die "Error in :del command: one or more attributes do not exist [@missing]. Aborted.\n"
    if @missing;
  print "Deleting attributes: @atts\n"; 
  foreach my $a (@atts) {
    $reg->delete_attribute($a);
  }
}

## add attributes of specified type
sub add_attributes {
  my $type = shift;
  my @atts = @_;
  if ($type eq "s") {           # automatic expansion of s-attribute specs in cwb-encode format
    my @expanded = ();
    foreach my $spec (@_) {
      if ($spec =~ /[:+]/) {
        my $path = undef;
        ($spec, $path) = split /=/, $spec; # remove optional directory path first
        die "Syntax error in s-attribute specifier '$spec'. Aborted.\n"
          unless $spec =~ /^([a-z0-9_-]+):([0-9])(\+([a-z0-9_+-]+))?$/;
        my $base = $1;
        my $recursion = $2;
        my @xmlatt = ($4) ? split /\+/, $4 : ();
        foreach my $i ("", 1 .. $recursion) {
          foreach my $ext ("", map {"_$_"} @xmlatt) {
            push @expanded, "$base$ext$i=$path";
          }
        }
      }
      else {
        push @expanded, $spec;
      }
    }
    @atts = @expanded;
  }
  my @invalid = grep {not /^[a-z_][a-z0-9_-]*(=[^=]+)?$/} @atts;
  die "Error in :add :$type command: invalid attribute name(s) [@invalid]. Aborted.\n"
    if @invalid;
  print "Adding $type-attributes: @atts\n";
  foreach my $spec (@atts) {
    my ($a, $path) = split /=/, $spec;
    my $exist = $reg->attribute($a);
    if ($exist) {
      die "Error: attribute '$a' already declared as $exist-attribute. Aborted.\n"
        unless $exist eq $type;
      print "[$type-attribute '$a' already declared]\n";