Author: guillem
Date: 2006-03-15 20:19:52 +0000 (Wed, 15 Mar 2006)
New Revision: 196
Added:
trunk/scripts/controllib.pl
Removed:
trunk/scripts/controllib.pl.in
Modified:
trunk/ChangeLog
trunk/debian/changelog
trunk/scripts/Makefile.am
trunk/scripts/dpkg-architecture.pl
trunk/scripts/dpkg-source.pl
Log:
Do not expand architecture aliases anymore in .dsc files.
Modified: trunk/ChangeLog
===================================================================
--- trunk/ChangeLog 2006-03-07 10:23:33 UTC (rev 195)
+++ trunk/ChangeLog 2006-03-15 20:19:52 UTC (rev 196)
@@ -1,3 +1,12 @@
+2006-03-15 Guillem Jover <[EMAIL PROTECTED]>
+
+ * scripts/controllib.pl.in: Rename to ...
+ * scripts/controllib.pl: ... this.
+ (debian_arch_expand): Remove function. Fix all callers.
+ (pkgdatadir, read_cputable, read_ostable): Move to ...
+ * scripts/dpkg-architecture.pl: ... here.
+ * scripts/Makefile.am (%.pl): Remove rule.
+
2006-03-05 Guillem Jover <[EMAIL PROTECTED]>
* scripts/controllib.pl.in (quiet_warnings): New variable.
Modified: trunk/debian/changelog
===================================================================
--- trunk/debian/changelog 2006-03-07 10:23:33 UTC (rev 195)
+++ trunk/debian/changelog 2006-03-15 20:19:52 UTC (rev 196)
@@ -16,6 +16,7 @@
* Add dpkg-query(1) in the SEE ALSO section in dpkg(1). Closes: #354643
* Don't try to compile in SELinux support on GNU/kFreeBSD amd64.
* Add new quiet option to dpkg-source to supress warnings. Closes: #355065
+ * Do not expand architecture aliases anymore in .dsc files.
[ Updated man pages translations ]
* Polish (Robert Luberda). Closes: #353782
Modified: trunk/scripts/Makefile.am
===================================================================
--- trunk/scripts/Makefile.am 2006-03-07 10:23:33 UTC (rev 195)
+++ trunk/scripts/Makefile.am 2006-03-15 20:19:52 UTC (rev 196)
@@ -70,11 +70,6 @@
$(do_perl_subst) <$< >$@
chmod +x $@
-%.pl: %.pl.in Makefile
- @test -d `dirname [EMAIL PROTECTED] || $(mkdir_p) `dirname [EMAIL
PROTECTED]
- $(do_perl_subst) <$< >$@
- chmod +x $@
-
%: %.sh Makefile
@test -d `dirname [EMAIL PROTECTED] || $(mkdir_p) `dirname [EMAIL
PROTECTED]
$(do_shell_subst) <$< >$@
Copied: trunk/scripts/controllib.pl (from rev 195,
trunk/scripts/controllib.pl.in)
===================================================================
--- trunk/scripts/controllib.pl.in 2006-03-07 10:23:33 UTC (rev 195)
+++ trunk/scripts/controllib.pl 2006-03-15 20:19:52 UTC (rev 196)
@@ -0,0 +1,412 @@
+#!/usr/bin/perl
+
+# Global variables:
+# $v - value parameter to function
+# $sourcepackage - name of sourcepackage
+# %fi - map of fields values. keys are of the form "S# key"
+# where S is source (L is changelog, C is control)
+# and # is an index
+# %p2i - map from datafile+packagename to index in controlfile
+# (used if multiple packages can be listed). Key is
+# "S key" where S is the source and key is the packagename
+# %substvar - map with substitution variables
+
+$parsechangelog= 'dpkg-parsechangelog';
+
[EMAIL PROTECTED] = qw(Replaces Provides Depends Pre-Depends Recommends Suggests
+ Conflicts Enhances);
[EMAIL PROTECTED] = qw(Build-Depends Build-Depends-Indep
+ Build-Conflicts Build-Conflicts-Indep);
+
+$substvar{'Format'}= 1.7;
+$substvar{'Newline'}= "\n";
+$substvar{'Space'}= " ";
+$substvar{'Tab'}= "\t";
+$maxsubsts=50;
+$warnable_error= 1;
+$quiet_warnings = 0;
+
+$progname= $0; $progname= $& if $progname =~ m,[^/]+$,;
+
+$getlogin = getlogin();
+if(!defined($getlogin)) {
+ open(SAVEIN, "<&STDIN");
+ close(STDIN);
+ open(STDIN, "<&STDERR");
+
+ $getlogin = getlogin();
+
+ close(STDIN);
+ open(STDIN, "<&SAVEIN");
+ close(SAVEIN);
+}
+if(!defined($getlogin)) {
+ open(SAVEIN, "<&STDIN");
+ close(STDIN);
+ open(STDIN, "<&STDOUT");
+
+ $getlogin = getlogin();
+
+ close(STDIN);
+ open(STDIN, "<&SAVEIN");
+ close(SAVEIN);
+}
+
+if (defined ($ENV{'LOGNAME'})) {
+ @fowner = getpwnam ($ENV{'LOGNAME'});
+ if (! @fowner) { die (sprintf ('unable to get login information for
username "%s"', $ENV{'LOGNAME'})); }
+} elsif (defined ($getlogin)) {
+ @fowner = getpwnam ($getlogin);
+ if (! @fowner) { die (sprintf ('unable to get login information for
username "%s"', $getlogin)); }
+} else {
+ &warn (sprintf ('no utmp entry available and LOGNAME not defined; using
uid of process (%d)', $<));
+ @fowner = getpwuid ($<);
+ if (! @fowner) { die (sprintf ('unable to get login information for uid
%d', $<)); }
+}
[EMAIL PROTECTED] = @fowner[2,3];
+
+sub capit {
+ my @pieces = map { ucfirst(lc) } split /-/, $_[0];
+ return join '-', @pieces;
+}
+
+sub findarch {
+ $arch=`dpkg-architecture -qDEB_HOST_ARCH`;
+ $? && &subprocerr("dpkg-architecture -qDEB_HOST_ARCH");
+ chomp $arch;
+ $substvar{'Arch'}= $arch;
+}
+
+sub debian_arch_fix
+{
+ local ($os, $cpu) = @_;
+
+ if ($os eq "linux") {
+ return $cpu;
+ } else {
+ return "$os-$cpu";
+ }
+}
+
+sub debian_arch_split {
+ local ($_) = @_;
+
+ if (/^([^-]*)-(.*)/) {
+ return ($1, $2);
+ } elsif (/any/ || /all/) {
+ return ($_, $_);
+ } else {
+ return ("linux", $_);
+ }
+}
+
+sub debian_arch_eq {
+ my ($a, $b) = @_;
+ my ($a_os, $a_cpu) = debian_arch_split($a);
+ my ($b_os, $b_cpu) = debian_arch_split($b);
+
+ return ("$a_os-$a_cpu" eq "$b_os-$b_cpu");
+}
+
+sub debian_arch_is {
+ my ($real, $alias) = @_;
+ my ($real_os, $real_cpu) = debian_arch_split($real);
+ my ($alias_os, $alias_cpu) = debian_arch_split($alias);
+
+ if ("$real_os-$real_cpu" eq "$alias_os-$alias_cpu") {
+ return 1;
+ } elsif ("$alias_os-$alias_cpu" eq "any-any") {
+ return 1;
+ } elsif ("$alias_os-$alias_cpu" eq "any-$real_cpu") {
+ return 1;
+ } elsif ("$alias_os-$alias_cpu" eq "$real_os-any") {
+ return 1;
+ }
+
+ return 0;
+}
+
+sub substvars {
+ my ($v) = @_;
+ my ($lhs,$vn,$rhs,$count);
+ $count=0;
+ while ($v =~ m/\$\{([-:0-9a-z]+)\}/i) {
+ # If we have consumed more from the leftover data, then
+ # reset the recursive counter.
+ $count= 0 if (length($') < length($rhs));
+
+ $count < $maxsubsts ||
+ &error("too many substitutions - recursive ? - in \`$v'");
+ $lhs=$`; $vn=$1; $rhs=$';
+ if (defined($substvar{$vn})) {
+ $v= $lhs.$substvar{$vn}.$rhs;
+ $count++;
+ } else {
+ &warn("unknown substitution variable \${$vn}");
+ $v= $lhs.$rhs;
+ }
+ }
+ return $v;
+}
+
+sub outputclose {
+ my ($dosubstvars) = @_;
+ for $f (keys %f) { $substvar{"F:$f"}= $f{$f}; }
+ &parsesubstvars if ($dosubstvars);
+ for $f (sort { $fieldimps{$b} <=> $fieldimps{$a} } keys %f) {
+ $v= $f{$f};
+ if ($dosubstvars) {
+ $v= &substvars($v);
+ }
+ $v =~ m/\S/ || next; # delete whitespace-only fields
+ $v =~ m/\n\S/ && &internerr("field $f has newline then non whitespace
>$v<");
+ $v =~ m/\n[ \t]*\n/ && &internerr("field $f has blank lines >$v<");
+ $v =~ m/\n$/ && &internerr("field $f has trailing newline >$v<");
+ if ($dosubstvars) {
+ $v =~ s/,[\s,]*,/,/g;
+ $v =~ s/^\s*,\s*//;
+ $v =~ s/\s*,\s*$//;
+ }
+ $v =~ s/\$\{\}/\$/g;
+ print("$f: $v\n") || &syserr("write error on control data");
+ }
+
+ close(STDOUT) || &syserr("write error on close control data");
+}
+
+sub parsecontrolfile {
+ $controlfile="./$controlfile" if $controlfile =~ m/^\s/;
+
+ open(CDATA,"< $controlfile") || &error("cannot read control file
$controlfile: $!");
+ binmode(CDATA);
+ $indices= &parsecdata('C',1,"control file $controlfile");
+ $indices >= 2 || &error("control file must have at least one binary
package part");
+
+ for ($i=1;$i<$indices;$i++) {
+ defined($fi{"C$i Package"}) ||
+ &error("per-package paragraph $i in control info file is ".
+ "missing Package line");
+ }
+ defined($fi{"C Source"}) ||
+ &error("source paragraph in control info file is ".
+ "missing Source line");
+
+}
+
+my $substvarsparsed = 0;
+sub parsesubstvars {
+ if (length($varlistfile) && !$substvarsparsed) {
+ $varlistfile="./$varlistfile" if $varlistfile =~ m/\s/;
+ if (open(SV,"< $varlistfile")) {
+ binmode(SV);
+ while (<SV>) {
+ next if m/^\#/ || !m/\S/;
+ s/\s*\n$//;
+ m/^(\w[-:0-9A-Za-z]*)\=/ ||
+ &error("bad line in substvars file $varlistfile at line
$.");
+ $substvar{$1}= $';
+ }
+ close(SV);
+ } elsif ($! != ENOENT ) {
+ &error("unable to open substvars file $varlistfile: $!");
+ }
+ $substvarsparsed = 1;
+ }
+}
+
+sub parsedep {
+ my ($dep_line, $use_arch, $reduce_arch) = @_;
+ my @dep_list;
+ if (!$host_arch) {
+ $host_arch = `dpkg-architecture -qDEB_HOST_ARCH`;
+ chomp $host_arch;
+ }
+ foreach my $dep_and (split(/,\s*/m, $dep_line)) {
+ my @or_list = ();
+ALTERNATE:
+ foreach my $dep_or (split(/\s*\|\s*/m, $dep_and)) {
+ my ($package, $relation, $version);
+ $package = $1 if ($dep_or =~
s/^([a-zA-Z0-9][a-zA-Z0-9+._-]*)\s*//m);
+ ($relation, $version) = ($1, $2)
+ if ($dep_or =~ s/^\(\s*(=|<=|>=|<<?|>>?)\s*([^)]+).*\)\s*//m);
+ my @arches;
+ @arches = split(/\s+/m, $1) if ($use_arch && $dep_or =~
s/^\[([^]]+)\]\s*//m);
+ if ($reduce_arch && @arches) {
+
+ my $seen_arch='';
+ foreach my $arch (@arches) {
+ $arch=lc($arch);
+ if (debian_arch_is($host_arch, $arch)) {
+ $seen_arch=1;
+ next;
+ } elsif ($arch =~ /^!/) {
+ ($not_arch = $arch) =~ s/^!//;
+
+ if (debian_arch_is($host_arch, $not_arch)) {
+ next ALTERNATE;
+ } else {
+ # This is equivilant to
+ # having seen the current arch,
+ # unless the current arch
+ # is also listed..
+ $seen_arch=1;
+ }
+ }
+ }
+ if (! $seen_arch) {
+ next;
+ }
+ }
+ if (length($dep_or)) {
+ &warn("can't parse dependency $dep_and");
+ return undef;
+ }
+ push @or_list, [ $package, $relation, $version, [EMAIL PROTECTED] ];
+ }
+ push @dep_list, [EMAIL PROTECTED];
+ }
+ [EMAIL PROTECTED];
+}
+
+sub showdep {
+ my ($dep_list, $show_arch) = @_;
+ my @and_list;
+ foreach my $dep_and (@$dep_list) {
+ my @or_list = ();
+ foreach my $dep_or (@$dep_and) {
+ my ($package, $relation, $version, $arch_list) = @$dep_or;
+ push @or_list, $package . ($relation && $version ? " ($relation
$version)" : '') . ($show_arch && @$arch_list ? " [EMAIL PROTECTED]" : '');
+ }
+ push @and_list, join(' | ', @or_list);
+ }
+ join(', ', @and_list);
+}
+
+sub parsechangelog {
+ defined($c=open(CDATA,"-|")) || &syserr("fork for parse changelog");
+ binmode(CDATA);
+ if (!$c) {
+ @al=($parsechangelog);
+ push(@al,"-F$changelogformat") if length($changelogformat);
+ push(@al,"-v$since") if length($since);
+ push(@al,"-l$changelogfile");
+ exec(@al) || &syserr("exec parsechangelog $parsechangelog");
+ }
+ &parsecdata('L',0,"parsed version of changelog");
+ close(CDATA); $? && &subprocerr("parse changelog");
+ $substvar{'Source-Version'}= $fi{"L Version"};
+}
+
+sub checkpackagename {
+ my $name = shift || '';
+ $name =~ m/[^-+.0-9a-z]/o &&
+ &error("source package name `$name' contains illegal character `$&'");
+ $name =~ m/^[0-9a-z]/o ||
+ &error("source package name `$name' starts with non-alphanum");
+}
+
+sub checkversion {
+ my $version = shift || '';
+ $version =~ m/[^-+:.0-9a-zA-Z~]/o &&
+ &error("version number contains illegal character `$&'");
+}
+
+sub setsourcepackage {
+ checkpackagename( $v );
+ if (length($sourcepackage)) {
+ $v eq $sourcepackage ||
+ &error("source package has two conflicting values - $sourcepackage
and $v");
+ } else {
+ $sourcepackage= $v;
+ }
+}
+
+sub readmd5sum {
+ (my $md5sum = shift) or return;
+ $md5sum =~ s/^([0-9a-f]{32})\s*\*?-?\s*\n?$/$1/o
+ || &failure("md5sum gave bogus output `$md5sum'");
+ return $md5sum;
+}
+
+sub parsecdata {
+ local ($source,$many,$whatmsg) = @_;
+ # many=0: ordinary control data like output from dpkg-parsechangelog
+ # many=1: many paragraphs like in source control file
+ # many=-1: single paragraph of control data optionally signed
+ local ($index,$cf,$paraborder);
+ $index=''; $cf=''; $paraborder=1;
+ while (<CDATA>) {
+ s/\s*\n$//;
+ next if (m/^$/ and $paraborder);
+ next if (m/^#/);
+ $paraborder=0;
+ if (m/^(\S+)\s*:\s*(.*)$/) {
+ $cf=$1; $v=$2;
+ $cf= &capit($cf);
+ $fi{"$source$index $cf"}= $v;
+ $fi{"o:$source$index $cf"}= $1;
+ if (lc $cf eq 'package') { $p2i{"$source $v"}= $index; }
+ } elsif (m/^\s+\S/) {
+ length($cf) || &syntax("continued value line not in field");
+ $fi{"$source$index $cf"}.= "\n$_";
+ } elsif (m/^-----BEGIN PGP/ && $many<0) {
+ $many == -2 && syntax("expected blank line before PGP signature");
+ while (<CDATA>) { last if m/^$/; }
+ $many= -2;
+ } elsif (m/^$/) {
+ $paraborder = 1;
+ if ($many>0) {
+ $index++; $cf='';
+ } elsif ($many == -2) {
+ $_= <CDATA> while defined($_) && $_ =~ /^\s*$/;
+ length($_) ||
+ &syntax("expected PGP signature, found EOF after blank
line");
+ s/\n$//;
+ m/^-----BEGIN PGP/ ||
+ &syntax("expected PGP signature, found something else
\`$_'");
+ $many= -3; last;
+ } else {
+ while (<CDATA>) {
+ /^\s*$/ ||
+ &syntax("found several \`paragraphs' where only one
expected");
+ }
+ }
+ } else {
+ &syntax("line with unknown format (not field-colon-value)");
+ }
+ }
+ $many == -2 && &syntax("found start of PGP body but no signature");
+ if (length($cf)) { $index++; }
+ $index || &syntax("empty file");
+ return $index;
+}
+
+sub unknown {
+ my $field = $_;
+ &warn("unknown information field \`$field\' in input data in $_[0]");
+}
+
+sub syntax {
+ &error("syntax error in $whatmsg at line $.: $_[0]");
+}
+
+sub failure { die "$progname: failure: $_[0]\n"; }
+sub syserr { die "$progname: failure: $_[0]: $!\n"; }
+sub error { die "$progname: error: $_[0]\n"; }
+sub internerr { die "$progname: internal error: $_[0]\n"; }
+sub warn { if (!$quiet_warnings) { warn "$progname: warning: $_[0]\n"; } }
+sub usageerr { print(STDERR "$progname: @_\n\n"); &usageversion; exit(2); }
+sub warnerror { if ($warnable_error) { &warn( @_ ); } else { &error( @_ ); } }
+
+sub subprocerr {
+ local ($p) = @_;
+ if (WIFEXITED($?)) {
+ die "$progname: failure: $p gave error exit status
".WEXITSTATUS($?)."\n";
+ } elsif (WIFSIGNALED($?)) {
+ die "$progname: failure: $p died from signal ".WTERMSIG($?)."\n";
+ } else {
+ die "$progname: failure: $p failed with unknown exit code $?\n";
+ }
+}
+
+1;
Deleted: trunk/scripts/controllib.pl.in
===================================================================
--- trunk/scripts/controllib.pl.in 2006-03-07 10:23:33 UTC (rev 195)
+++ trunk/scripts/controllib.pl.in 2006-03-15 20:19:52 UTC (rev 196)
@@ -1,475 +0,0 @@
-#!/usr/bin/perl
-
-# Global variables:
-# $v - value parameter to function
-# $sourcepackage - name of sourcepackage
-# %fi - map of fields values. keys are of the form "S# key"
-# where S is source (L is changelog, C is control)
-# and # is an index
-# %p2i - map from datafile+packagename to index in controlfile
-# (used if multiple packages can be listed). Key is
-# "S key" where S is the source and key is the packagename
-# %substvar - map with substitution variables
-
-$pkgdatadir=".";
-
-$parsechangelog= 'dpkg-parsechangelog';
-
[EMAIL PROTECTED] = qw(Replaces Provides Depends Pre-Depends Recommends Suggests
- Conflicts Enhances);
[EMAIL PROTECTED] = qw(Build-Depends Build-Depends-Indep
- Build-Conflicts Build-Conflicts-Indep);
-
-$substvar{'Format'}= 1.7;
-$substvar{'Newline'}= "\n";
-$substvar{'Space'}= " ";
-$substvar{'Tab'}= "\t";
-$maxsubsts=50;
-$warnable_error= 1;
-$quiet_warnings = 0;
-
-$progname= $0; $progname= $& if $progname =~ m,[^/]+$,;
-
-$getlogin = getlogin();
-if(!defined($getlogin)) {
- open(SAVEIN, "<&STDIN");
- close(STDIN);
- open(STDIN, "<&STDERR");
-
- $getlogin = getlogin();
-
- close(STDIN);
- open(STDIN, "<&SAVEIN");
- close(SAVEIN);
-}
-if(!defined($getlogin)) {
- open(SAVEIN, "<&STDIN");
- close(STDIN);
- open(STDIN, "<&STDOUT");
-
- $getlogin = getlogin();
-
- close(STDIN);
- open(STDIN, "<&SAVEIN");
- close(SAVEIN);
-}
-
-if (defined ($ENV{'LOGNAME'})) {
- @fowner = getpwnam ($ENV{'LOGNAME'});
- if (! @fowner) { die (sprintf ('unable to get login information for
username "%s"', $ENV{'LOGNAME'})); }
-} elsif (defined ($getlogin)) {
- @fowner = getpwnam ($getlogin);
- if (! @fowner) { die (sprintf ('unable to get login information for
username "%s"', $getlogin)); }
-} else {
- &warn (sprintf ('no utmp entry available and LOGNAME not defined; using
uid of process (%d)', $<));
- @fowner = getpwuid ($<);
- if (! @fowner) { die (sprintf ('unable to get login information for uid
%d', $<)); }
-}
[EMAIL PROTECTED] = @fowner[2,3];
-
-sub capit {
- my @pieces = map { ucfirst(lc) } split /-/, $_[0];
- return join '-', @pieces;
-}
-
-sub findarch {
- $arch=`dpkg-architecture -qDEB_HOST_ARCH`;
- $? && &subprocerr("dpkg-architecture -qDEB_HOST_ARCH");
- chomp $arch;
- $substvar{'Arch'}= $arch;
-}
-
-sub read_cputable {
- open CPUTABLE, "$pkgdatadir/cputable"
- or &syserr("unable to open cputable");
- while (<CPUTABLE>) {
- if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) {
- $cputable{$1} = $2;
- $cputable_re{$1} = $3;
- push @cpu, $1;
- }
- }
- close CPUTABLE;
-}
-
-sub read_ostable {
- open OSTABLE, "$pkgdatadir/ostable"
- or &syserr("unable to open ostable");
- while (<OSTABLE>) {
- if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) {
- $ostable{$1} = $2;
- $ostable_re{$1} = $3;
- push @os, $1;
- }
- }
- close OSTABLE;
-}
-
-sub debian_arch_fix
-{
- local ($os, $cpu) = @_;
-
- if ($os eq "linux") {
- return $cpu;
- } else {
- return "$os-$cpu";
- }
-}
-
-sub debian_arch_split {
- local ($_) = @_;
-
- if (/^([^-]*)-(.*)/) {
- return ($1, $2);
- } elsif (/any/ || /all/) {
- return ($_, $_);
- } else {
- return ("linux", $_);
- }
-}
-
-sub debian_arch_eq {
- my ($a, $b) = @_;
- my ($a_os, $a_cpu) = debian_arch_split($a);
- my ($b_os, $b_cpu) = debian_arch_split($b);
-
- return ("$a_os-$a_cpu" eq "$b_os-$b_cpu");
-}
-
-sub debian_arch_is {
- my ($real, $alias) = @_;
- my ($real_os, $real_cpu) = debian_arch_split($real);
- my ($alias_os, $alias_cpu) = debian_arch_split($alias);
-
- if ("$real_os-$real_cpu" eq "$alias_os-$alias_cpu") {
- return 1;
- } elsif ("$alias_os-$alias_cpu" eq "any-any") {
- return 1;
- } elsif ("$alias_os-$alias_cpu" eq "any-$real_cpu") {
- return 1;
- } elsif ("$alias_os-$alias_cpu" eq "$real_os-any") {
- return 1;
- }
-
- return 0;
-}
-
-&read_cputable;
-&read_ostable;
-
-sub debian_arch_expand
-{
- local ($_) = @_;
-
- /^(!)?(.*)/;
-
- local $not = $1 || '';
- local $arch = $2;
- local ($os, $cpu) = debian_arch_split($arch);
- local @list;
-
- if ("$os-$cpu" eq 'any-any') {
- @list = 'any';
- } elsif ($os eq 'all' or $cpu eq 'all') {
- @list = 'all';
- } elsif ($cpu eq 'any') {
- foreach my $_cpu (@cpu) {
- push @list, $not.debian_arch_fix($os, $_cpu);
- }
- } elsif ($os eq 'any') {
- foreach my $_os (@os) {
- push @list, $not.debian_arch_fix($_os, $cpu);
- }
- } else {
- push @list, $not.debian_arch_fix($os, $cpu);
- }
-
- return @list;
-}
-
-sub substvars {
- my ($v) = @_;
- my ($lhs,$vn,$rhs,$count);
- $count=0;
- while ($v =~ m/\$\{([-:0-9a-z]+)\}/i) {
- # If we have consumed more from the leftover data, then
- # reset the recursive counter.
- $count= 0 if (length($') < length($rhs));
-
- $count < $maxsubsts ||
- &error("too many substitutions - recursive ? - in \`$v'");
- $lhs=$`; $vn=$1; $rhs=$';
- if (defined($substvar{$vn})) {
- $v= $lhs.$substvar{$vn}.$rhs;
- $count++;
- } else {
- &warn("unknown substitution variable \${$vn}");
- $v= $lhs.$rhs;
- }
- }
- return $v;
-}
-
-sub outputclose {
- my ($dosubstvars) = @_;
- for $f (keys %f) { $substvar{"F:$f"}= $f{$f}; }
- &parsesubstvars if ($dosubstvars);
- for $f (sort { $fieldimps{$b} <=> $fieldimps{$a} } keys %f) {
- $v= $f{$f};
- if ($dosubstvars) {
- $v= &substvars($v);
- }
- $v =~ m/\S/ || next; # delete whitespace-only fields
- $v =~ m/\n\S/ && &internerr("field $f has newline then non whitespace
>$v<");
- $v =~ m/\n[ \t]*\n/ && &internerr("field $f has blank lines >$v<");
- $v =~ m/\n$/ && &internerr("field $f has trailing newline >$v<");
- if ($dosubstvars) {
- $v =~ s/,[\s,]*,/,/g;
- $v =~ s/^\s*,\s*//;
- $v =~ s/\s*,\s*$//;
- }
- $v =~ s/\$\{\}/\$/g;
- print("$f: $v\n") || &syserr("write error on control data");
- }
-
- close(STDOUT) || &syserr("write error on close control data");
-}
-
-sub parsecontrolfile {
- $controlfile="./$controlfile" if $controlfile =~ m/^\s/;
-
- open(CDATA,"< $controlfile") || &error("cannot read control file
$controlfile: $!");
- binmode(CDATA);
- $indices= &parsecdata('C',1,"control file $controlfile");
- $indices >= 2 || &error("control file must have at least one binary
package part");
-
- for ($i=1;$i<$indices;$i++) {
- defined($fi{"C$i Package"}) ||
- &error("per-package paragraph $i in control info file is ".
- "missing Package line");
- }
- defined($fi{"C Source"}) ||
- &error("source paragraph in control info file is ".
- "missing Source line");
-
-}
-
-my $substvarsparsed = 0;
-sub parsesubstvars {
- if (length($varlistfile) && !$substvarsparsed) {
- $varlistfile="./$varlistfile" if $varlistfile =~ m/\s/;
- if (open(SV,"< $varlistfile")) {
- binmode(SV);
- while (<SV>) {
- next if m/^\#/ || !m/\S/;
- s/\s*\n$//;
- m/^(\w[-:0-9A-Za-z]*)\=/ ||
- &error("bad line in substvars file $varlistfile at line
$.");
- $substvar{$1}= $';
- }
- close(SV);
- } elsif ($! != ENOENT ) {
- &error("unable to open substvars file $varlistfile: $!");
- }
- $substvarsparsed = 1;
- }
-}
-
-sub parsedep {
- my ($dep_line, $use_arch, $reduce_arch) = @_;
- my @dep_list;
- if (!$host_arch) {
- $host_arch = `dpkg-architecture -qDEB_HOST_ARCH`;
- chomp $host_arch;
- }
- foreach my $dep_and (split(/,\s*/m, $dep_line)) {
- my @or_list = ();
-ALTERNATE:
- foreach my $dep_or (split(/\s*\|\s*/m, $dep_and)) {
- my ($package, $relation, $version);
- $package = $1 if ($dep_or =~
s/^([a-zA-Z0-9][a-zA-Z0-9+._-]*)\s*//m);
- ($relation, $version) = ($1, $2)
- if ($dep_or =~ s/^\(\s*(=|<=|>=|<<?|>>?)\s*([^)]+).*\)\s*//m);
- my @arches;
- @arches = split(/\s+/m, $1) if ($use_arch && $dep_or =~
s/^\[([^]]+)\]\s*//m);
- if ($reduce_arch && @arches) {
-
- my $seen_arch='';
- foreach my $arch (@arches) {
- $arch=lc($arch);
- if (debian_arch_is($host_arch, $arch)) {
- $seen_arch=1;
- next;
- } elsif ($arch =~ /^!/) {
- ($not_arch = $arch) =~ s/^!//;
-
- if (debian_arch_is($host_arch, $not_arch)) {
- next ALTERNATE;
- } else {
- # This is equivilant to
- # having seen the current arch,
- # unless the current arch
- # is also listed..
- $seen_arch=1;
- }
- }
- }
- if (! $seen_arch) {
- next;
- }
- }
- if (length($dep_or)) {
- &warn("can't parse dependency $dep_and");
- return undef;
- }
- push @or_list, [ $package, $relation, $version, [EMAIL PROTECTED] ];
- }
- push @dep_list, [EMAIL PROTECTED];
- }
- [EMAIL PROTECTED];
-}
-
-sub showdep {
- my ($dep_list, $show_arch) = @_;
- my @and_list;
- foreach my $dep_and (@$dep_list) {
- my @or_list = ();
- foreach my $dep_or (@$dep_and) {
- my ($package, $relation, $version, $arch_list) = @$dep_or;
- my @arches = map(debian_arch_expand($_), @$arch_list);
- chomp @arches;
- push @or_list, $package . ($relation && $version ? " ($relation
$version)" : '') . ($show_arch && @arches ? " [EMAIL PROTECTED]" : '');
- }
- push @and_list, join(' | ', @or_list);
- }
- join(', ', @and_list);
-}
-
-sub parsechangelog {
- defined($c=open(CDATA,"-|")) || &syserr("fork for parse changelog");
- binmode(CDATA);
- if (!$c) {
- @al=($parsechangelog);
- push(@al,"-F$changelogformat") if length($changelogformat);
- push(@al,"-v$since") if length($since);
- push(@al,"-l$changelogfile");
- exec(@al) || &syserr("exec parsechangelog $parsechangelog");
- }
- &parsecdata('L',0,"parsed version of changelog");
- close(CDATA); $? && &subprocerr("parse changelog");
- $substvar{'Source-Version'}= $fi{"L Version"};
-}
-
-sub checkpackagename {
- my $name = shift || '';
- $name =~ m/[^-+.0-9a-z]/o &&
- &error("source package name `$name' contains illegal character `$&'");
- $name =~ m/^[0-9a-z]/o ||
- &error("source package name `$name' starts with non-alphanum");
-}
-
-sub checkversion {
- my $version = shift || '';
- $version =~ m/[^-+:.0-9a-zA-Z~]/o &&
- &error("version number contains illegal character `$&'");
-}
-
-sub setsourcepackage {
- checkpackagename( $v );
- if (length($sourcepackage)) {
- $v eq $sourcepackage ||
- &error("source package has two conflicting values - $sourcepackage
and $v");
- } else {
- $sourcepackage= $v;
- }
-}
-
-sub readmd5sum {
- (my $md5sum = shift) or return;
- $md5sum =~ s/^([0-9a-f]{32})\s*\*?-?\s*\n?$/$1/o
- || &failure("md5sum gave bogus output `$md5sum'");
- return $md5sum;
-}
-
-sub parsecdata {
- local ($source,$many,$whatmsg) = @_;
- # many=0: ordinary control data like output from dpkg-parsechangelog
- # many=1: many paragraphs like in source control file
- # many=-1: single paragraph of control data optionally signed
- local ($index,$cf,$paraborder);
- $index=''; $cf=''; $paraborder=1;
- while (<CDATA>) {
- s/\s*\n$//;
- next if (m/^$/ and $paraborder);
- next if (m/^#/);
- $paraborder=0;
- if (m/^(\S+)\s*:\s*(.*)$/) {
- $cf=$1; $v=$2;
- $cf= &capit($cf);
- $fi{"$source$index $cf"}= $v;
- $fi{"o:$source$index $cf"}= $1;
- if (lc $cf eq 'package') { $p2i{"$source $v"}= $index; }
- } elsif (m/^\s+\S/) {
- length($cf) || &syntax("continued value line not in field");
- $fi{"$source$index $cf"}.= "\n$_";
- } elsif (m/^-----BEGIN PGP/ && $many<0) {
- $many == -2 && syntax("expected blank line before PGP signature");
- while (<CDATA>) { last if m/^$/; }
- $many= -2;
- } elsif (m/^$/) {
- $paraborder = 1;
- if ($many>0) {
- $index++; $cf='';
- } elsif ($many == -2) {
- $_= <CDATA> while defined($_) && $_ =~ /^\s*$/;
- length($_) ||
- &syntax("expected PGP signature, found EOF after blank
line");
- s/\n$//;
- m/^-----BEGIN PGP/ ||
- &syntax("expected PGP signature, found something else
\`$_'");
- $many= -3; last;
- } else {
- while (<CDATA>) {
- /^\s*$/ ||
- &syntax("found several \`paragraphs' where only one
expected");
- }
- }
- } else {
- &syntax("line with unknown format (not field-colon-value)");
- }
- }
- $many == -2 && &syntax("found start of PGP body but no signature");
- if (length($cf)) { $index++; }
- $index || &syntax("empty file");
- return $index;
-}
-
-sub unknown {
- my $field = $_;
- &warn("unknown information field \`$field\' in input data in $_[0]");
-}
-
-sub syntax {
- &error("syntax error in $whatmsg at line $.: $_[0]");
-}
-
-sub failure { die "$progname: failure: $_[0]\n"; }
-sub syserr { die "$progname: failure: $_[0]: $!\n"; }
-sub error { die "$progname: error: $_[0]\n"; }
-sub internerr { die "$progname: internal error: $_[0]\n"; }
-sub warn { if (!$quiet_warnings) { warn "$progname: warning: $_[0]\n"; } }
-sub usageerr { print(STDERR "$progname: @_\n\n"); &usageversion; exit(2); }
-sub warnerror { if ($warnable_error) { &warn( @_ ); } else { &error( @_ ); } }
-
-sub subprocerr {
- local ($p) = @_;
- if (WIFEXITED($?)) {
- die "$progname: failure: $p gave error exit status
".WEXITSTATUS($?)."\n";
- } elsif (WIFSIGNALED($?)) {
- die "$progname: failure: $p died from signal ".WTERMSIG($?)."\n";
- } else {
- die "$progname: failure: $p failed with unknown exit code $?\n";
- }
-}
-
-1;
Modified: trunk/scripts/dpkg-architecture.pl
===================================================================
--- trunk/scripts/dpkg-architecture.pl 2006-03-07 10:23:33 UTC (rev 195)
+++ trunk/scripts/dpkg-architecture.pl 2006-03-15 20:19:52 UTC (rev 196)
@@ -26,6 +26,8 @@
push(@INC,$dpkglibdir);
require 'controllib.pl';
+$pkgdatadir=".";
+
sub usageversion {
print STDERR
"Debian $0 $version.
@@ -52,6 +54,32 @@
";
}
+sub read_cputable {
+ open CPUTABLE, "$pkgdatadir/cputable"
+ or &syserr("unable to open cputable");
+ while (<CPUTABLE>) {
+ if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) {
+ $cputable{$1} = $2;
+ $cputable_re{$1} = $3;
+ push @cpu, $1;
+ }
+ }
+ close CPUTABLE;
+}
+
+sub read_ostable {
+ open OSTABLE, "$pkgdatadir/ostable"
+ or &syserr("unable to open ostable");
+ while (<OSTABLE>) {
+ if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) {
+ $ostable{$1} = $2;
+ $ostable_re{$1} = $3;
+ push @os, $1;
+ }
+ }
+ close OSTABLE;
+}
+
sub split_debian {
local ($_) = @_;
@@ -101,6 +129,9 @@
return debian_arch_fix($os, $cpu);
}
+&read_cputable;
+&read_ostable;
+
# Check for -L
if (grep { m/^-L$/ } @ARGV) {
foreach $os (@os) {
Modified: trunk/scripts/dpkg-source.pl
===================================================================
--- trunk/scripts/dpkg-source.pl 2006-03-07 10:23:33 UTC (rev 195)
+++ trunk/scripts/dpkg-source.pl 2006-03-15 20:19:52 UTC (rev 196)
@@ -202,10 +202,7 @@
if (grep($sourcearch[0] eq $_, 'any','all')) {
@sourcearch= ('any');
} else {
- my @arches = map(debian_arch_expand($_),
- split(/\s+/, $v));
- chomp @arches;
- for $a (@arches) {
+ for $a (split(/\s+/, $v)) {
&error("`$a' is not a legal architecture string")
unless $a =~ /^[\w-]+$/;
&error("architecture $a only allowed on its own".
--
To UNSUBSCRIBE, email to [EMAIL PROTECTED]
with a subject of "unsubscribe". Trouble? Contact [EMAIL PROTECTED]
