#!/usr/bin/perl
$| = 1;
sub
Usage {
die
<<STOP;
Usage: cwb-regedit [options] (CORPUS | <filename>) <command> [<command> ...]
Options:
-r <dir> use registry directory <dir> [system default]
--registry=<dir>
-h show this help page
--help
Commands:
:info print basic information about the registry entry
:reg print pathname of registry file
(:id | :home | :name | :ifile) [<value>]
print or set corpus ID (:id), data directory (:home),
descriptive name (:name) or info file path (:ifile)
:prop <property> [<value>]
query or set corpus property
:list (:p | :s | :a)
list declared attributes of specified type
:add (:p | :s | :a) <name>[=<path>] ...
add positional, structural or alignment attributes
:del <names>
delete attributes of any type
Command names are case-insensitive, and some intuitive abbreviations and variations
are allowed (but only the forms listed above are guaranteed to work).
STOP
}
our
$Registry
=
undef
;
our
$Help
= 0;
{
my
$ok
= GetOptions(
"r|registry=s"
=> \
$Registry
,
"h|help"
=> \
$Help
,
);
Usage()
if
$Help
or
@ARGV
< 2 or not
$ok
;
}
our
$Corpus
=
shift
@ARGV
;
if
(
defined
$Registry
) {
$ENV
{CORPUS_REGISTRY} =
$Registry
;
}
our
$reg
= new CWB::RegistryFile
$Corpus
;
die
"Registry file not found. Aborted.\n"
unless
defined
$reg
;
our
$COMMAND
=
""
;
our
@ARGS
= ();
our
$CHANGES
= 0;
while
(get_block()) {
if
(
$COMMAND
eq
":info"
) {
die
"Syntax error: :info command does not take arguments (@ARGS)\n"
unless
@ARGS
== 0;
print
"FILE\t"
,
$reg
->filename,
"\n"
;
print
"ID\t"
,
uc
(
$reg
->id),
"\n"
;
print
"NAME\t"
,
$reg
->name,
"\n"
;
print
"HOME\t"
,
$reg
->home,
"\n"
;
print
"INFO\t"
,
$reg
->info,
"\n"
if
$reg
->info;
foreach
my
$p
(
$reg
->list_properties) {
print
"##::\t$p = "
,
$reg
->property(
$p
),
"\n"
;
}
}
elsif
(
$COMMAND
=~ /^:(id|home|name|ifile|reg)$/) {
my
$cmd
= $1;
die
"Syntax error: :$cmd command takes only 1 optional argument\n"
if
@ARGS
> 1;
if
(
@ARGS
== 1) {
my
$v
=
shift
@ARGS
;
$reg
->id(
$v
)
if
$cmd
eq
"id"
;
$reg
->home(
$v
)
if
$cmd
eq
"home"
;
$reg
->name(
$v
)
if
$cmd
eq
"name"
;
$reg
->info(
$v
)
if
$cmd
eq
"ifile"
;
die
"Error: can't modify pathname of registry file with :reg\n"
if
$cmd
eq
"reg"
;
$CHANGES
++;
}
else
{
print
$reg
->id
if
$cmd
eq
"id"
;
print
$reg
->home
if
$cmd
eq
"home"
;
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"
) {
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"
) {
die
"Syntax error: arguments missing for :del\n"
unless
@ARGS
> 0;
delete_attributes(
@ARGS
);
$CHANGES
++;
}
elsif
(
$COMMAND
eq
":list"
) {
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"
;
}
}
if
(
$CHANGES
> 0) {
my
$regfile
=
$reg
->filename;
system
"cp"
,
"-p"
,
$regfile
,
"$regfile~"
;
$reg
->
write
;
print
"Changes saved to "
,
$reg
->filename,
"\n"
;
}
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
);
}
}
sub
add_attributes {
my
$type
=
shift
;
my
@atts
=
@_
;
if
(
$type
eq
"s"
) {
my
@expanded
= ();
foreach
my
$spec
(
@_
) {
if
(
$spec
=~ /[:+]/) {
my
$path
=
undef
;
(
$spec
,
$path
) =
split
/=/,
$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=$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"
;
}
$reg
->add_attribute(
$a
,
$type
);
$reg
->attribute_path(
$a
,
$path
)
if
defined
$path
;
}
}
sub
list_attributes {
my
$type
=
shift
;
my
@atts
=
$reg
->list_attributes(
$type
);
print
"@atts\n"
;
}
sub
is_command {
return
(
@ARGV
and
$ARGV
[0] =~ /^:/ );
}
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
=
":reg"
if
/^:(reg(istry)?|file)$/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
;
}
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
;
while
(
@ARGV
and not is_command()) {
push
@ARGS
,
shift
@ARGV
;
}
return
1;
}