OpenPKG CVS Repository
http://cvs.openpkg.org/
____________________________________________________________________________
Server: cvs.openpkg.org Name: Ralf S. Engelschall
Root: /e/openpkg/cvs Email: [EMAIL PROTECTED]
Module: openpkg-tools Date: 09-Apr-2004 12:20:30
Branch: HEAD Handle: 2004040911203000
Added files:
openpkg-tools/api/OpenPKG/RPM
Filename.pm
Log:
first cut for filename module
Summary:
Revision Changes Path
1.1 +299 -0 openpkg-tools/api/OpenPKG/RPM/Filename.pm
____________________________________________________________________________
patch -p0 <<'@@ .'
Index: openpkg-tools/api/OpenPKG/RPM/Filename.pm
============================================================================
$ cvs diff -u -r0 -r1.1 Filename.pm
--- /dev/null 2004-04-09 12:20:30.000000000 +0200
+++ Filename.pm 2004-04-09 12:20:30.000000000 +0200
@@ -0,0 +1,299 @@
+##
+## OpenPKG Tool Chain
+## Copyright (c) 2000-2004 The OpenPKG Project <http://www.openpkg.org/>
+## Copyright (c) 2000-2004 Ralf S. Engelschall <[EMAIL PROTECTED]>
+## Copyright (c) 2000-2004 Cable & Wireless <http://www.cw.com>/
+##
+## Permission to use, copy, modify, and distribute this software for
+## any purpose with or without fee is hereby granted, provided that
+## the above copyright notice and this permission notice appear in all
+## copies.
+##
+## THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
+## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
+## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
+## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+## SUCH DAMAGE.
+##
+## api/OpenPKG/RPM/Filename.pm: RPM Filename Handling
+##
+
+package OpenPKG::RPM::Filename;
+
+use OpenPKG::Obj;
+use Carp;
+use vars qw($AUTOLOAD);
+
[EMAIL PROTECTED] = qw(OpenPKG::Obj);
[EMAIL PROTECTED] = qw(parse format);
+
+sub new ($) {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ bless ($self, $class);
+
+ $self->{-name} = '';
+ $self->{-version} = '';
+ $self->{-release} = '';
+ $self->{-type} = '';
+ $self->{-ext} = '';
+
+ my $filename = shift;
+ $self->parse($filename) if (defined($filename));
+
+ return $self;
+}
+
+sub parse ($$) {
+ my $self = shift;
+ my ($filename) = @_;
+
+ my $croak_msg = "unable to parse OpenPKG RPM filename";
+ if ($filename =~
m/^(.+?)-([^-]+)-([^-]+)\.((?:no)?src|[^-]+-[^-]+-[^-]+)\.(rpm)$/i) {
+ my ($name, $version, $release, $type, $ext) = ($1, $2, $3, $4, $5);
+
+ # parse name
+ if ($name =~ m/^[a-z][a-zA-Z0-9_-]*$/) {
+ $name = { -class => 'openpkg', -string => $name };
+ }
+ elsif ($name =~ m/^[A-Z][a-zA-Z0-9_-]*$/) {
+ $name = { -class => 'vendor', -string => $name };
+ }
+ else {
+ croak "$croak_msg: invalid name \"$name\"";
+ }
+
+ # parse version
+ # (nothing possible, because can be mostly arbitrary)
+ $version = { -string => $version };
+
+ # parse release
+ # (very strict because has to allow subtle decisions)
+ my $r;
+ my $vendor = 0;
+ if ($release =~
s/^([2-9]\d\d\d)(0[1-9]|1[0-2])(0[1-9]|[1-2][0-9]|3[0-1])//) {
+ $r = { -class => 'CURRENT', -year => $1, -month => $2, -day => $3 };
+ }
+ elsif ($release =~
s/^([1-9]\d*)\.([2-9]\d\d\d)(0[1-9]|1[0-2])(0[1-9]|[1-2][0-9]|3[0-1])//) {
+ $r = { -class => 'STABLE', -major => $1, -year => $2, -month => $3,
-day => $4 };
+ }
+ elsif ($release =~ s/^([1-9]\d*)\.(\d+)\.(\d+)//) {
+ $r = { -class => 'RELEASE', -major => $1, -minor => $2, -revision => $3
};
+ }
+ else {
+ $r = { -class => 'VENDOR' };
+ $vendor++;
+ }
+ $r->{-vendor} = undef;
+ $release =~ s/^\.// if ($vendor == 0);
+ if ($release =~ s/^([^.]+)//) {
+ $vendor++;
+ my $tag = $1;
+ if ($tag !~ m|[a-zA-Z]|) {
+ croak "$croak_msg: invalid vendor tag \"$tag\" in release part
\"$release\""
+ }
+ $r->{-vendor} = { -tag => $tag, -release => '' };
+ $release =~ s/^\.//;
+ my $r2;
+ if ($release =~
s/^([2-9]\d\d\d)(0[1-9]|1[0-2])(0[1-9]|[1-2][0-9]|3[0-1])//) {
+ $r2 = { -class => 'CURRENT', -year => $1, -month => $2, -day => $3
};
+ }
+ elsif ($release =~
s/^([1-9]\d*)\.([2-9]\d\d\d)(0[1-9]|1[0-2])(0[1-9]|[1-2][0-9]|3[0-1])//) {
+ $r2 = { -class => 'STABLE', -major => $1, -year => $2, -month =>
$3, -day => $4 };
+ }
+ elsif ($release =~ s/^([1-9]\d*)(?:\.(\d+)(?:\.(\d+))?)?//) {
+ $r2 = { -class => 'RELEASE', -major => $1, -minor => $2, -revision
=> $3 };
+ }
+ else {
+ croak "$croak_msg: invalid vendor release \"$release\"";
+ }
+ $r->{-vendor}->{-release} = $2;
+ }
+ $release = $r;
+ if ($vendor == 1) {
+ croak "$croak_msg: vendor part expected but not found";
+ }
+
+ # parse type
+ if ($type eq 'src') {
+ $type = { -class => 'src', -restriction => 0 };
+ }
+ elsif ($type eq 'nosrc') {
+ $type = { -class => 'src', -restriction => 1 };
+ }
+ elsif ($type =~ m/^([^-]+)-([^-]+)-([^-]+)$/) {
+ $type = { -class => 'bin', -arch => $1, -os => $2, -tag => $3 };
+ }
+ else {
+ croak "$croak_msg: invalid type part \"$type\"";
+ }
+
+ # parse extension
+ $ext = { -string => $ext };
+
+ # take over assembled information into object
+ $self->{-name} = $name;
+ $self->{-version} = $version;
+ $self->{-release} = $release;
+ $self->{-type} = $type;
+ $self->{-ext} = $ext;
+ }
+ else {
+ croak "$croak_msg: invalid general layout \"$filename\"";
+ }
+}
+
+sub format ($) {
+ my $self = shift;
+
+ my $filename = '';
+ $filename .= $self->{-name}->{-string} . "-";
+ $filename .= $self->{-version}->{-string} . "-";
+ $filename .=
+ ( $self->{-release}->{-class} eq 'CURRENT'
+ ? sprintf("%04d%02d%02d", $self->{-release}->{-year},
+ $self->{-release}->{-month}, $self->{-release}->{-date})
+ : ( $self->{-release}->{-class} eq 'STABLE'
+ ? sprintf("%d.%04d%02d%02d", $self->{-release}->{-major},
$self->{-release}->{-year},
+ $self->{-release}->{-month}, $self->{-release}->{-date})
+ : sprintf("%d.%d.%d", $self->{-release}->{-major},
+ $self->{-release}->{-minor}, $self->{-release}->{-revision})
+ )
+ );
+ if (defined($self->{-release}->{-vendor})) {
+ $filename .= $self->{-release}->{-vendor}->{-tag} . "-";
+ if (defined($self->{-release}->{-vendor}->{-release})) {
+ my $r = $self->{-release}->{-vendor}->{-release};
+ $filename .=
+ ( $r->{-class} eq 'CURRENT'
+ ? sprintf("%04d%02d%02d", $r->{-year}, $r->{-month}, $r->{-date})
+ : ( $r-{-class} eq 'STABLE'
+ ? sprintf("%d.%04d%02d%02d", $r->{-major}, $r->{-year},
$r->{-month}, $r->{-date})
+ : ( (defined($r->{-major}) ? sprintf("%d", $r->{-major})
: '') .
+ (defined($r->{-minor}) ? sprintf(".%d", $r->{-minor})
: '') .
+ (defined($r->{-revision}) ? sprintf(".%d",
$r->{-revision}) : '')
+ )
+ )
+ );
+ }
+ }
+ $filename .= ".";
+ if ($self->{-type}->{-class} eq 'src') {
+ $filename .= ($self->{-type}->{-restriction} ? "nosrc" : "src");
+ }
+ else {
+ $filename .=
+ $self->{-type}->{-arch} . "-" .
+ $self->{-type}->{-os} . "-" .
+ $self->{-type}->{-tag};
+ }
+ $filename .= "." . $self->{-ext}->{-string};
+ return $filename;
+}
+
+sub comp ($;$) {
+ my $self = shift;
+ my ($name, $new) = @_;
+
+ my $var = $name;
+ $var =~ s|^([^:]+)|\$self->{-$1}|s;
+ $var =~ s|::([^:]+)|->{-$1}|sg;
+
+ my $exists;
+ eval "\$exists = defined($var);";
+ if (not $exists) {
+ croak "variable \"$name\" does not exist";
+ }
+ my $old;
+ eval "\$old = $var;";
+ if (not defined($old)) {
+ croak "variable \"$name\" resolved to undefined value";
+ }
+ if (ref($old)) {
+ croak "variable \"$name\" resolved to non-scalar value";
+ }
+ if (defined($new)) {
+ eval "$var = \$new;";
+ }
+ return $old;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+B<OpenPKG::RPM::Filename> - OpenPKG RPM Filename Handling
+
+=head1 DESCRIPTION
+
+B<OpenPKG::RPM::Filename> is the RPM filename class of the OpenPKG Tool Chain Perl
API.
+It provides parsing and generating of RPM filenames.
+
+=head1 METHODS
+
+=over 4
+
+=item C<$fn = >B<new>C< OpenPKG::RPM::Filename> [C<$filename>]C<;>
+
+=item C<$fn-E<gt>>B<destroy>C<;>
+
+Create and destroy object.
+
+=item C<$path = $ctx-E<gt>>B<tool>C<;>
+
+=item C<$ctx-E<gt>>B<tool>C<($path);>
+
+Get and set path to the B<openpkg> execution frontend. This
+is preinitialized to the value of environment variable
+C<$OPENPKG_TOOLS_TOOL> as provided by the B<openpkg> execution frontend
+initially.
+
+=item C<$path = $ctx-E<gt>>B<home>C<;>
+
+=item C<$ctx-E<gt>>B<home>C<($path);>
+
+Get and set path to OpenPKG Tool Chain home directory. This
+is preinitialized to the value of environment variable
+C<$OPENPKG_TOOLS_HOME> as provided by the B<openpkg> execution
+frontend initially.
+
+=item C<$path = $ctx-E<gt>>B<instance>C<;>
+
+=item C<$ctx-E<gt>>B<instance>C<($path);>
+
+Get and set path to OpenPKG instance (prefix directory).
+This is preinitialized to the value of environment variable
+C<$OPENPKG_TOOLS_INST> as provided by the B<openpkg> execution frontend
+initially if an OpenPKG instance was found.
+
+=item C<$path = $ctx-E<gt>>B<perl>C<;>
+
+=item C<$ctx-E<gt>>B<perl>C<($path);>
+
+Get and set path to Perl interpreter executable. This
+is preinitialized to the value of environment variable
+C<$OPENPKG_TOOLS_PERL> as provided by the B<openpkg> execution
+frontend initially.
+
+=head1 SEE ALSO
+
+L<OpenPKG(3)>.
+
+=head1 AUTHOR
+
+The OpenPKG Project E<lt>http://www.openpkg.org/E<gt>
+
+=cut
+
@@ .
______________________________________________________________________
The OpenPKG Project www.openpkg.org
CVS Repository Commit List [EMAIL PROTECTED]
