[p5sagit/p5-mst-13.2.git] / ext / Devel-PPPort / parts / ppptools.pl

################################################################################
#
#  ppptools.pl -- various utility functions
#
################################################################################
#
#  $Revision: 27 $
#  $Author: mhx $
#  $Date: 2009/01/18 14:10:51 +0100 $
#
################################################################################
#
#  Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
#  Version 2.x, Copyright (C) 2001, Paul Marquess.
#  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
#
#  This program is free software; you can redistribute it and/or
#  modify it under the same terms as Perl itself.
#
################################################################################

sub cat_file
{
  eval { require File::Spec };
  return $@ ? join('/', @_) : File::Spec->catfile(@_);
}

sub all_files_in_dir
{
  my $dir = shift;
  local *DIR;

  opendir DIR, $dir or die "cannot open directory $dir: $!\n";
  my @files = grep { !-d && !/^\./ } readdir DIR;  # no dirs or hidden files
  closedir DIR;

  return map { cat_file($dir, $_) } @files;
}

sub parse_todo
{
  my $dir = shift || 'parts/todo';
  local *TODO;
  my %todo;
  my $todo;

  for $todo (all_files_in_dir($dir)) {
    open TODO, $todo or die "cannot open $todo: $!\n";
    my $perl = <TODO>;
    chomp $perl;
    while (<TODO>) {
      chomp;
      s/#.*//;
      s/^\s+//; s/\s+$//;
      /^\s*$/ and next;
      /^\w+$/ or die "invalid identifier: $_\n";
      exists $todo{$_} and die "duplicate identifier: $_ ($todo{$_} <=> $perl)\n";
      $todo{$_} = $perl;
    }
    close TODO;
  }

  return \%todo;
}

sub expand_version
{
  my($op, $ver) = @_;
  my($r, $v, $s) = parse_version($ver);
  $r == 5 or die "only Perl revision 5 is supported\n";
  my $bcdver = sprintf "0x%d%03d%03d", $r, $v, $s;
  return "(PERL_BCDVERSION $op $bcdver)";
}

sub parse_partspec
{
  my $file = shift;
  my $section = 'implementation';
  my $vsec = join '|', qw( provides dontwarn implementation
                           xsubs xsinit xsmisc xshead xsboot tests );
  my(%data, %options);
  local *F;

  open F, $file or die "$file: $!\n";
  while (<F>) {
    /[ \t]+$/ and warn "$file:$.: warning: trailing whitespace\n";
    if ($section eq 'implementation') {
      m!//! && !m!(?:=~|s/).*//! && !m!(?:ht|f)tp://!
          and warn "$file:$.: warning: potential C++ comment\n";
    }
    /^##/ and next;
    if (/^=($vsec)(?:\s+(.*))?/) {
      $section = $1;
      if (defined $2) {
        my $opt = $2;
        $options{$section} = eval "{ $opt }";
        $@ and die "$file:$.: invalid options ($opt) in section $section: $@\n";
      }
      next;
    }
    push @{$data{$section}}, $_;
  }
  close F;

  for (keys %data) {
    my @v = @{$data{$_}};
    shift @v while @v && $v[0]  =~ /^\s*$/;
    pop   @v while @v && $v[-1] =~ /^\s*$/;
    $data{$_} = join '', @v;
  }

  unless (exists $data{provides}) {
    $data{provides} = ($file =~ /(\w+)\.?$/)[0];
  }
  $data{provides} = [$data{provides} =~ /(\S+)/g];

  if (exists $data{dontwarn}) {
    $data{dontwarn} = [$data{dontwarn} =~ /(\S+)/g];
  }

  my @prov;
  my %proto;

  if (exists $data{tests} && (!exists $data{implementation} || $data{implementation} !~ /\S/)) {
    $data{implementation} = '';
  }
  else {
    $data{implementation} =~ /\S/ or die "Empty implementation in $file\n";

    my $p;

    for $p (@{$data{provides}}) {
      if ($p =~ m#^/.*/\w*$#) {
        my @tmp = eval "\$data{implementation} =~ ${p}gm";
        $@ and die "invalid regex $p in $file\n";
        @tmp or warn "no matches for regex $p in $file\n";
        push @prov, do { my %h; grep !$h{$_}++, @tmp };
      }
      elsif ($p eq '__UNDEFINED__') {
        my @tmp = $data{implementation} =~ /^\s*__UNDEFINED__[^\r\n\S]+(\w+)/gm;
        @tmp or warn "no __UNDEFINED__ macros in $file\n";
        push @prov, @tmp;
      }
      else {
        push @prov, $p;
      }
    }

    for (@prov) {
      if ($data{implementation} !~ /\b\Q$_\E\b/) {
        warn "$file claims to provide $_, but doesn't seem to do so\n";
        next;
      }

      # scan for prototypes
      my($proto) = $data{implementation} =~ /
                   ( ^ (?:[\w*]|[^\S\r\n])+
                       [\r\n]*?
                     ^ \b$_\b \s*
                       \( [^{]* \)
                   )
                       \s* \{
                   /xm or next;

      $proto =~ s/^\s+//;
      $proto =~ s/\s+$//;
      $proto =~ s/\s+/ /g;

      exists $proto{$_} and warn "$file: duplicate prototype for $_\n";
      $proto{$_} = $proto;
    }
  }

  for $section (qw( implementation xsubs xsinit xsmisc xshead xsboot )) {
    if (exists $data{$section}) {
      $data{$section} =~ s/\{\s*version\s*(<|>|==|!=|>=|<=)\s*([\d._]+)\s*\}/expand_version($1, $2)/gei;
    }
  }

  $data{provides}   = \@prov;
  $data{prototypes} = \%proto;
  $data{OPTIONS}    = \%options;

  my %prov     = map { ($_ => 1) } @prov;
  my %dontwarn = exists $data{dontwarn} ? map { ($_ => 1) } @{$data{dontwarn}} : ();
  my @maybeprov = do { my %h;
                       grep {
                         my($nop) = /^Perl_(.*)/;
                         not exists $prov{$_}                         ||
                             exists $dontwarn{$_}                     ||
                             /^D_PPP_/                                ||
                             (defined $nop && exists $prov{$nop}    ) ||
                             (defined $nop && exists $dontwarn{$nop}) ||
                             $h{$_}++;
                       }
                       $data{implementation} =~ /^\s*#\s*define\s+(\w+)/gm };

  if (@maybeprov) {
    warn "$file seems to provide these macros, but doesn't list them:\n  "
         . join("\n  ", @maybeprov) . "\n";
  }

  return \%data;
}

sub compare_prototypes
{
  my($p1, $p2) = @_;
  for ($p1, $p2) {
    s/^\s+//;
    s/\s+$//;
    s/\s+/ /g;
    s/(\w)\s(\W)/$1$2/g;
    s/(\W)\s(\w)/$1$2/g;
  }
  return $p1 cmp $p2;
}

sub ppcond
{
  my $s = shift;
  my @c;
  my $p;

  for $p (@$s) {
    push @c, map "!($_)", @{$p->{pre}};
    defined $p->{cur} and push @c, "($p->{cur})";
  }

  join " && ", @c;
}

sub trim_arg
{
  my $in = shift;
  my $remove = join '|', qw( NN NULLOK VOL );

  $in eq '...' and return ($in);

  local $_ = $in;
  my $id;

  s/[*()]/ /g;
  s/\[[^\]]*\]/ /g;
  s/\b(?:auto|const|extern|inline|register|static|volatile|restrict)\b//g;
  s/\b(?:$remove)\b//;
  s/^\s*//; s/\s*$//;

  if( /^\b(?:struct|union|enum)\s+\w+(?:\s+(\w+))?$/ ) {
    defined $1 and $id = $1;
  }
  else {
    if( s/\b(?:char|double|float|int|long|short|signed|unsigned|void)\b//g ) {
      /^\s*(\w+)\s*$/ and $id = $1;
    }
    else {
      /^\s*\w+\s+(\w+)\s*$/ and $id = $1;
    }
  }

  $_ = $in;

  defined $id and s/\b$id\b//;

  # these don't matter at all
  s/\b(?:auto|extern|inline|register|static|volatile|restrict)\b//g;
  s/\b(?:$remove)\b//;

  s/(?=<\*)\s+(?=\*)//g;
  s/\s*(\*+)\s*/ $1 /g;
  s/^\s*//; s/\s*$//;
  s/\s+/ /g;

  return ($_, $id);
}

sub parse_embed
{
  my @files = @_;
  my @func;
  my @pps;
  my $file;
  local *FILE;

  for $file (@files) {
    open FILE, $file or die "$file: $!\n";
    my($line, $l);

    while (defined($line = <FILE>)) {
      while ($line =~ /\\$/ && defined($l = <FILE>)) {
        $line =~ s/\\\s*//;
        $line .= $l;
      }
      next if $line =~ /^\s*:/;
      $line =~ s/^\s+|\s+$//gs;
      my($dir, $args) = ($line =~ /^\s*#\s*(\w+)(?:\s*(.*?)\s*)?$/);
      if (defined $dir and defined $args) {
        for ($dir) {
          /^ifdef$/   and do { push @pps, { pre => [], cur => "defined($args)"  }         ; last };
          /^ifndef$/  and do { push @pps, { pre => [], cur => "!defined($args)" }         ; last };
          /^if$/      and do { push @pps, { pre => [], cur => $args             }         ; last };
          /^elif$/    and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = $args; last };
          /^else$/    and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = undef; last };
          /^endif$/   and do { pop @pps                                                   ; last };
          /^include$/ and last;
          /^define$/  and last;
          /^undef$/   and last;
          warn "unhandled preprocessor directive: $dir\n";
        }
      }
      else {
        my @e = split /\s*\|\s*/, $line;
        if( @e >= 3 ) {
          my($flags, $ret, $name, @args) = @e;
          for (@args) {
            $_ = [trim_arg($_)];
          }
          ($ret) = trim_arg($ret);
          push @func, {
            name  => $name,
            flags => { map { $_, 1 } $flags =~ /./g },
            ret   => $ret,
            args  => \@args,
            cond  => ppcond(\@pps),
          };
        }
      }
    }

    close FILE;
  }

  return @func;
}

sub make_prototype
{
  my $f = shift;
  my @args = map { "@$_" } @{$f->{args}};
  my $proto;
  my $pTHX_ = exists $f->{flags}{n} ? "" : "pTHX_ ";
  $proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')';
  return $proto;
}

sub format_version
{
  my $ver = shift;

  $ver =~ s/$/000000/;
  my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;

  $v = int $v;
  $s = int $s;

  if ($r < 5 || ($r == 5 && $v < 6)) {
    if ($s % 10) {
      die "invalid version '$ver'\n";
    }
    $s /= 10;

    $ver = sprintf "%d.%03d", $r, $v;
    $s > 0 and $ver .= sprintf "_%02d", $s;

    return $ver;
  }

  return sprintf "%d.%d.%d", $r, $v, $s;
}

sub parse_version
{
  my $ver = shift;

  if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
    return ($1, $2, $3);
  }
  elsif ($ver !~ /^\d+\.[\d_]+$/) {
    die "cannot parse version '$ver'\n";
  }

  $ver =~ s/_//g;
  $ver =~ s/$/000000/;

  my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;

  $v = int $v;
  $s = int $s;

  if ($r < 5 || ($r == 5 && $v < 6)) {
    if ($s % 10) {
      die "cannot parse version '$ver'\n";
    }
    $s /= 10;
  }

  return ($r, $v, $s);
}

1;
Commit	Line	Data
adfe19db	1	################################################################################
	2	#
	3	# ppptools.pl -- various utility functions
	4	#
	5	################################################################################
	6	#
51d6c659	7	# $Revision: 27 $
adfe19db	8	# $Author: mhx $
51d6c659	9	# $Date: 2009/01/18 14:10:51 +0100 $
adfe19db	10	#
	11	################################################################################
	12	#
51d6c659	13	# Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
adfe19db	14	# Version 2.x, Copyright (C) 2001, Paul Marquess.
	15	# Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
	16	#
	17	# This program is free software; you can redistribute it and/or
	18	# modify it under the same terms as Perl itself.
	19	#
	20	################################################################################
	21
1d088ed8	22	sub cat_file
	23	{
	24	eval { require File::Spec };
	25	return $@ ? join('/', @_) : File::Spec->catfile(@_);
	26	}
	27
	28	sub all_files_in_dir
	29	{
	30	my $dir = shift;
	31	local *DIR;
	32
	33	opendir DIR, $dir or die "cannot open directory $dir: $!\n";
	34	my @files = grep { !-d && !/^\./ } readdir DIR; # no dirs or hidden files
	35	closedir DIR;
	36
	37	return map { cat_file($dir, $_) } @files;
	38	}
	39
adfe19db	40	sub parse_todo
	41	{
	42	my $dir = shift \|\| 'parts/todo';
	43	local *TODO;
	44	my %todo;
	45	my $todo;
	46
1d088ed8	47	for $todo (all_files_in_dir($dir)) {
adfe19db	48	open TODO, $todo or die "cannot open $todo: $!\n";
	49	my $perl = <TODO>;
	50	chomp $perl;
	51	while (<TODO>) {
	52	chomp;
	53	s/#.*//;
	54	s/^\s+//; s/\s+$//;
	55	/^\s*$/ and next;
	56	/^\w+$/ or die "invalid identifier: $_\n";
	57	exists $todo{$_} and die "duplicate identifier: $_ ($todo{$_} <=> $perl)\n";
	58	$todo{$_} = $perl;
	59	}
	60	close TODO;
	61	}
	62
	63	return \%todo;
	64	}
	65
96ad942f	66	sub expand_version
	67	{
	68	my($op, $ver) = @_;
	69	my($r, $v, $s) = parse_version($ver);
	70	$r == 5 or die "only Perl revision 5 is supported\n";
c83e6f19	71	my $bcdver = sprintf "0x%d%03d%03d", $r, $v, $s;
c83e6f19	72	return "(PERL_BCDVERSION $op $bcdver)";
96ad942f	73	}
96ad942f	74
adfe19db	75	sub parse_partspec
	76	{
	77	my $file = shift;
	78	my $section = 'implementation';
	79	my $vsec = join '\|', qw( provides dontwarn implementation
	80	xsubs xsinit xsmisc xshead xsboot tests );
	81	my(%data, %options);
	82	local *F;
	83
	84	open F, $file or die "$file: $!\n";
	85	while (<F>) {
c83e6f19	86	/[ \t]+$/ and warn "$file:$.: warning: trailing whitespace\n";
	87	if ($section eq 'implementation') {
	88	m!//! && !m!(?:=~\|s/).*//! && !m!(?:ht\|f)tp://!
	89	and warn "$file:$.: warning: potential C++ comment\n";
	90	}
adfe19db	91	/^##/ and next;
	92	if (/^=($vsec)(?:\s+(.*))?/) {
	93	$section = $1;
	94	if (defined $2) {
	95	my $opt = $2;
	96	$options{$section} = eval "{ $opt }";
c83e6f19	97	$@ and die "$file:$.: invalid options ($opt) in section $section: $@\n";
adfe19db	98	}
	99	next;
	100	}
	101	push @{$data{$section}}, $_;
	102	}
	103	close F;
	104
	105	for (keys %data) {
	106	my @v = @{$data{$_}};
	107	shift @v while @v && $v[0] =~ /^\s*$/;
	108	pop @v while @v && $v[-1] =~ /^\s*$/;
	109	$data{$_} = join '', @v;
	110	}
	111
	112	unless (exists $data{provides}) {
597c4554	113	$data{provides} = ($file =~ /(\w+)\.?$/)[0];
adfe19db	114	}
	115	$data{provides} = [$data{provides} =~ /(\S+)/g];
	116
	117	if (exists $data{dontwarn}) {
	118	$data{dontwarn} = [$data{dontwarn} =~ /(\S+)/g];
	119	}
	120
	121	my @prov;
	122	my %proto;
	123
	124	if (exists $data{tests} && (!exists $data{implementation} \|\| $data{implementation} !~ /\S/)) {
	125	$data{implementation} = '';
	126	}
	127	else {
	128	$data{implementation} =~ /\S/ or die "Empty implementation in $file\n";
	129
	130	my $p;
	131
	132	for $p (@{$data{provides}}) {
	133	if ($p =~ m#^/./\w$#) {
	134	my @tmp = eval "\$data{implementation} =~ ${p}gm";
	135	$@ and die "invalid regex $p in $file\n";
	136	@tmp or warn "no matches for regex $p in $file\n";
	137	push @prov, do { my %h; grep !$h{$_}++, @tmp };
	138	}
	139	elsif ($p eq '__UNDEFINED__') {
	140	my @tmp = $data{implementation} =~ /^\s*__UNDEFINED__[^\r\n\S]+(\w+)/gm;
	141	@tmp or warn "no __UNDEFINED__ macros in $file\n";
	142	push @prov, @tmp;
	143	}
	144	else {
	145	push @prov, $p;
	146	}
	147	}
	148
	149	for (@prov) {
	150	if ($data{implementation} !~ /\b\Q$_\E\b/) {
	151	warn "$file claims to provide $_, but doesn't seem to do so\n";
	152	next;
	153	}
	154
	155	# scan for prototypes
	156	my($proto) = $data{implementation} =~ /
	157	( ^ (?:[\w*]\|[^\S\r\n])+
	158	[\r\n]*?
	159	^ \b$_\b \s*
	160	\( [^{]* \)
	161	)
	162	\s* \{
	163	/xm or next;
	164
	165	$proto =~ s/^\s+//;
	166	$proto =~ s/\s+$//;
	167	$proto =~ s/\s+/ /g;
	168
	169	exists $proto{$_} and warn "$file: duplicate prototype for $_\n";
	170	$proto{$_} = $proto;
	171	}
	172	}
	173
96ad942f	174	for $section (qw( implementation xsubs xsinit xsmisc xshead xsboot )) {
	175	if (exists $data{$section}) {
	176	$data{$section} =~ s/\{\sversion\s(<\|>\|==\|!=\|>=\|<=)\s([\d._]+)\s\}/expand_version($1, $2)/gei;
	177	}
	178	}
	179
adfe19db	180	$data{provides} = \@prov;
	181	$data{prototypes} = \%proto;
	182	$data{OPTIONS} = \%options;
	183
	184	my %prov = map { ($_ => 1) } @prov;
	185	my %dontwarn = exists $data{dontwarn} ? map { ($_ => 1) } @{$data{dontwarn}} : ();
	186	my @maybeprov = do { my %h;
	187	grep {
	188	my($nop) = /^Perl_(.*)/;
	189	not exists $prov{$_} \|\|
	190	exists $dontwarn{$_} \|\|
c01be2ce	191	/^D_PPP_/ \|\|
adfe19db	192	(defined $nop && exists $prov{$nop} ) \|\|
	193	(defined $nop && exists $dontwarn{$nop}) \|\|
	194	$h{$_}++;
	195	}
af36fda7	196	$data{implementation} =~ /^\s#\sdefine\s+(\w+)/gm };
adfe19db	197
	198	if (@maybeprov) {
	199	warn "$file seems to provide these macros, but doesn't list them:\n "
	200	. join("\n ", @maybeprov) . "\n";
	201	}
	202
	203	return \%data;
	204	}
	205
	206	sub compare_prototypes
	207	{
	208	my($p1, $p2) = @_;
	209	for ($p1, $p2) {
	210	s/^\s+//;
	211	s/\s+$//;
	212	s/\s+/ /g;
	213	s/(\w)\s(\W)/$1$2/g;
	214	s/(\W)\s(\w)/$1$2/g;
	215	}
	216	return $p1 cmp $p2;
	217	}
	218
	219	sub ppcond
	220	{
	221	my $s = shift;
	222	my @c;
	223	my $p;
	224
	225	for $p (@$s) {
	226	push @c, map "!($_)", @{$p->{pre}};
	227	defined $p->{cur} and push @c, "($p->{cur})";
	228	}
	229
	230	join " && ", @c;
	231	}
	232
	233	sub trim_arg
	234	{
	235	my $in = shift;
9c0a17a0	236	my $remove = join '\|', qw( NN NULLOK VOL );
adfe19db	237
	238	$in eq '...' and return ($in);
	239
	240	local $_ = $in;
	241	my $id;
4a582685	242
adfe19db	243	s/[*()]/ /g;
	244	s/\[[^\]]*\]/ /g;
	245	s/\b(?:auto\|const\|extern\|inline\|register\|static\|volatile\|restrict)\b//g;
4a582685	246	s/\b(?:$remove)\b//;
adfe19db	247	s/^\s//; s/\s$//;
	248
	249	if( /^\b(?:struct\|union\|enum)\s+\w+(?:\s+(\w+))?$/ ) {
	250	defined $1 and $id = $1;
	251	}
	252	else {
	253	if( s/\b(?:char\|double\|float\|int\|long\|short\|signed\|unsigned\|void)\b//g ) {
	254	/^\s(\w+)\s$/ and $id = $1;
	255	}
	256	else {
	257	/^\s\w+\s+(\w+)\s$/ and $id = $1;
	258	}
	259	}
	260
	261	$_ = $in;
	262
	263	defined $id and s/\b$id\b//;
	264
	265	# these don't matter at all
	266	s/\b(?:auto\|extern\|inline\|register\|static\|volatile\|restrict)\b//g;
4a582685	267	s/\b(?:$remove)\b//;
adfe19db	268
	269	s/(?=<\)\s+(?=\)//g;
	270	s/\s(\+)\s*/ $1 /g;
	271	s/^\s//; s/\s$//;
	272	s/\s+/ /g;
	273
	274	return ($_, $id);
	275	}
	276
	277	sub parse_embed
	278	{
	279	my @files = @_;
	280	my @func;
	281	my @pps;
	282	my $file;
	283	local *FILE;
	284
	285	for $file (@files) {
	286	open FILE, $file or die "$file: $!\n";
	287	my($line, $l);
	288
	289	while (defined($line = <FILE>)) {
	290	while ($line =~ /\\$/ && defined($l = <FILE>)) {
	291	$line =~ s/\\\s*//;
	292	$line .= $l;
	293	}
	294	next if $line =~ /^\s*:/;
	295	$line =~ s/^\s+\|\s+$//gs;
	296	my($dir, $args) = ($line =~ /^\s#\s(\w+)(?:\s(.?)\s*)?$/);
	297	if (defined $dir and defined $args) {
	298	for ($dir) {
	299	/^ifdef$/ and do { push @pps, { pre => [], cur => "defined($args)" } ; last };
	300	/^ifndef$/ and do { push @pps, { pre => [], cur => "!defined($args)" } ; last };
	301	/^if$/ and do { push @pps, { pre => [], cur => $args } ; last };
	302	/^elif$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = $args; last };
	303	/^else$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = undef; last };
	304	/^endif$/ and do { pop @pps ; last };
	305	/^include$/ and last;
	306	/^define$/ and last;
	307	/^undef$/ and last;
	308	warn "unhandled preprocessor directive: $dir\n";
	309	}
	310	}
	311	else {
	312	my @e = split /\s\\|\s/, $line;
	313	if( @e >= 3 ) {
	314	my($flags, $ret, $name, @args) = @e;
	315	for (@args) {
	316	$_ = [trim_arg($_)];
	317	}
	318	($ret) = trim_arg($ret);
	319	push @func, {
	320	name => $name,
	321	flags => { map { $_, 1 } $flags =~ /./g },
	322	ret => $ret,
	323	args => \@args,
	324	cond => ppcond(\@pps),
	325	};
	326	}
	327	}
	328	}
	329
	330	close FILE;
	331	}
332
333	return @func;
334	}
335
336	sub make_prototype
337	{
338	my $f = shift;
339	my @args = map { "@$_" } @{$f->{args}};
340	my $proto;
341	my $pTHX_ = exists $f->{flags}{n} ? "" : "pTHX_ ";
342	$proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')';
343	return $proto;
344	}
345
346	sub format_version
347	{
348	my $ver = shift;
349
350	$ver =~ s/$/000000/;
351	my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
352
353	$v = int $v;
354	$s = int $s;
355
356	if ($r < 5 \|\| ($r == 5 && $v < 6)) {
357	if ($s % 10) {
358	die "invalid version '$ver'\n";
359	}
360	$s /= 10;
361
362	$ver = sprintf "%d.%03d", $r, $v;
363	$s > 0 and $ver .= sprintf "_%02d", $s;
364
365	return $ver;
366	}
367
368	return sprintf "%d.%d.%d", $r, $v, $s;
369	}
370
371	sub parse_version
372	{
373	my $ver = shift;
374
375	if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
376	return ($1, $2, $3);
377	}
378	elsif ($ver !~ /^\d+\.[\d_]+$/) {
379	die "cannot parse version '$ver'\n";
380	}
381
382	$ver =~ s/_//g;
383	$ver =~ s/$/000000/;
384
385	my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
386
387	$v = int $v;
388	$s = int $s;
389
390	if ($r < 5 \|\| ($r == 5 && $v < 6)) {
391	if ($s % 10) {
392	die "cannot parse version '$ver'\n";
393	}
394	$s /= 10;
395	}
396
397	return ($r, $v, $s);
398	}
399
400	1;