view release on metacpan or  search on metacpan

script/cwb-regedit  view on Meta::CPAN

## 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 =~ /[:+]/) {
        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";
          }
        }
      }
      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 $a (@atts) {
    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";
    }
    $reg->add_attribute($a, $type);
  }
}

## list attributes of specified type
sub list_attributes {
  my $type = shift;
  my @atts = $reg->list_attributes($type);
  print "@atts\n";
}

## check whether next token looks like a command (without removing it)
sub is_command {
  return( @ARGV and $ARGV[0] =~ /^:/ );
}

## match next token as command (without removing it) and return normalised name ("" if not a command)
sub match_command {
  my $cmd = (@_) ? shift : $ARGV[0];
  my $norm = "";
  for ($cmd) {
    last unless defined $cmd;
    $norm = ":info"  if /^:info$/i;
    $norm = ":id"    if /^:id$/i;
    $norm = ":home"  if /^:h(ome)?$/i;
    $norm = ":name"  if /^:n(ame)?$/i;
    $norm = ":ifile" if /^:ifile$/i;
    $norm = ":prop"  if /^:pr(op)?$/i;
    $norm = ":add"   if /^:add$/i;
    $norm = lc($cmd) if /^:[psa]$/i;
    $norm = ":del"   if /^:d(el(ete)?)?$/i;
    $norm = ":list"   if /^:l(ist)?$/i;
  }
  return $norm;
}

## get a command block from the command line (command plus any number of non-command arguments)
## result is stored in global variables $COMMAND and @ARGS; returns FALSE at end of input 
sub get_block {
  $COMMAND = "";
  @ARGS = ();
  return 0
    unless @ARGV > 0;
  die "Syntax error: expected command, got '$ARGV[0]'\n"
    unless is_command();
  $COMMAND = match_command();
  die "Syntax error: unknown command '$ARGV[0]'\n"
    unless $COMMAND;
  shift @ARGV;
  # collect command arguments (if any)
  while (@ARGV and not is_command()) {
    push @ARGS, shift @ARGV;
  }
  return 1;
}

__END__

=head1 NAME

cwb-regedit - A simple command-line editor for CWB registry files

=head1 SYNOPSIS

  cwb-regedit [options] (CORPUS | <filename>) <command> [<command> ...]

Options:

  -r <dir>, --registry=<dir>  use registry directory <dir> [system default]
  -h, --help                  display usage summary