checkpointing laptop to repository

CVS patchset: 3762
CVS date: 2000/05/27 05:22:51

6 files changed, 280 insertions, 68 deletions

diff --git a/Perl-RPM/ChangeLog b/Perl-RPM/ChangeLog
index 1f3c5ffa4..4ed5cb576 100644
--- a/Perl-RPM/ChangeLog
+++ b/Perl-RPM/ChangeLog
@@ -12,3 +12,23 @@ Revision history for Perl extension RPM.
 	exported symbols, rather than lengthening it). A basic top-level
 	RPM namespace is present, but doesn't yet do anything useful. Some
 	basic test scripts are in place, but more are (always) needed.
+
+0.2
+	- second alpha
+
+	Class for RPM::Error added. The code is in the RPM.xs file, but
+	the docs and accessors are done in RPM/Error.pm.
+
+	All sub-classes moved to RPM/.
+
+	More documentation added, especially to RPM::Constants.
+
+	RPM::Constants had about a dozen or so trimmed out.
+
+	Found error in Database.xs where the FIRSTKEY/NEXTKEY pair would
+	have returned string-ified references instead of package names,
+	because of not taking the first array element. I really plan to
+	change the RPM::Header::FETCH interface.
+
+	Added two utility functions under the RPM::* space for getting O/S
+	and architecture names.
diff --git a/Perl-RPM/Makefile.PL b/Perl-RPM/Makefile.PL
index b99caa0e2..bb8c8fa48 100644
--- a/Perl-RPM/Makefile.PL
+++ b/Perl-RPM/Makefile.PL
@@ -1,10 +1,10 @@
 use ExtUtils::MakeMaker;
 
 %XS = qw(
-         RPM.xs                     RPM.c
-         Constants/Constants.xs     Constants/Constants.c
-         Database/Database.xs       Database/Database.c
-         Header/Header.xs           Header/Header.c
+         RPM.xs             RPM.c
+         RPM/Constants.xs   RPM/Constants.c
+         RPM/Database.xs    RPM/Database.c
+         RPM/Header.xs      RPM/Header.c
         );
 
 @OBJECT = values %XS;
@@ -14,21 +14,17 @@ for (@OBJECT)
 }
 $OBJECT = join(' ', @OBJECT);
 
-@DIRS = qw(Constants Header Database);
-
 %PM = map { ($from = $_) =~ s/xs$/pm/;
-            ($to = $from) =~ s|.*?/|RPM/|;
-            ($from, "\$(INST_LIBDIR)/$to"); } (sort keys %XS);
+            ($from, "\$(INST_LIBDIR)/$from"); } (sort keys %XS);
+$PM{q(RPM/Error.pm)} = '$(INST_LIBDIR)/RPM/Error.pm';
 
-# Make symlinks for typemap in the sub-dirs
-for (@DIRS)
-{
-    symlink '../typemap', "$_/typemap";
-}
+# This shouldn't be necessary, I don't think, but for now it is
+unlink 'RPM/typemap';
+symlink '../typemap', 'RPM/typemap';
 
 # Cruft that MakeMaker wouldn't inherently know about
-$CLEAN = join(' ', map { "$_/typemap" } @DIRS) . " $OBJECT";
-$CLEAN .= ' pod2html-* */pod2html-* *.html */*.html';
+$CLEAN = join(' ', values %XS) . " $OBJECT";
+$CLEAN .= ' pod2html-* */pod2html-* *.html */*.html RPM/typemap';
 
 WriteMakefile(
               NAME         => 'RPM',
@@ -36,13 +32,13 @@ WriteMakefile(
               VERSION_FROM => 'RPM.pm',
               LIBS         => '-lrpm -lpopt',
               DEFINE       => '',
-              XS           => \%XS,
               PM           => \%PM,
+              XS           => \%XS,
               OBJECT       => $OBJECT,
               INC          => '-I/usr/include/rpm',
+              DIR          => [],
               dist         => { COMPRESS => 'gzip -9f' },
               clean        => { FILES => $CLEAN },
-              #realclean    => { FILES => $CLEAN },
              );
 
 sub MY::c_o
@@ -50,7 +46,8 @@ sub MY::c_o
     package MY; # so that "SUPER" works right
 
     my $text = shift->SUPER::c_o(@_);
-    $text =~ s/CCCMD.*$/$&\n\t\@if test -f `basename \$*.o` -a "`basename \$*.o`" != "\$*.o"; then mv `basename \$*.o` \$*.o; fi/m;
+
+    $text =~ s/CCCMD.*$/$& -o \$*\$(OBJ_EXT)/gm;
 
     $text;
 }
diff --git a/Perl-RPM/RPM.h b/Perl-RPM/RPM.h
index d2deafb2e..27a5fa1dc 100644
--- a/Perl-RPM/RPM.h
+++ b/Perl-RPM/RPM.h
@@ -1,5 +1,5 @@
 /*
- * $Id: RPM.h,v 1.1 2000/05/22 08:37:23 rjray Exp $
+ * $Id: RPM.h,v 1.2 2000/05/27 05:22:51 rjray Exp $
  *
  * Various C-specific decls/includes/etc. for the RPM linkage
  */
@@ -40,9 +40,12 @@
 #include <rpm/header.h>
 #include <rpm/dbindex.h>
 
-extern const char* sv2key(SV *);
-extern int tag2num(const char *);
-extern const char* num2tag(int);
+//
+// This is the underlying struct that implements the interface to the RPM
+// database. Since we need the actual object to be a hash, the struct will
+// be stored as an SV (actually, a pointer to a struct) on a special key
+// defined below.
+//
 
 typedef struct {
     rpmdb dbp;
@@ -54,6 +57,13 @@ typedef HV* RPM__Database;
 
 #define new_RPM__Database(x) x = newHV()
 
+//
+// This is the underlying struct that implements the interface to the RPM
+// headers. As above, we need the actual object to be a hash, so the struct
+// will be stored as an SV on the same sort of special key as RPM__Database
+// uses.
+//
+
 typedef struct {
     Header hdr;
     // These three tags will probably cover at leas 80% of data requests
@@ -79,13 +89,13 @@ typedef HV* RPM__Header;
 // Because the HV* are going to be set magical, the following is needed for
 // explicit fetch and store calls that are done within the tied FETCH/STORE
 #define hv_fetch_nomg(SVP, h, k, kl, f) \
-	SvMAGICAL_off((SV *)(h)); \
-	(SVP) = hv_fetch((h), (k), (kl), (f)); \
-	SvMAGICAL_on((SV *)(h))
+        SvMAGICAL_off((SV *)(h)); \
+        (SVP) = hv_fetch((h), (k), (kl), (f)); \
+        SvMAGICAL_on((SV *)(h))
 #define hv_store_nomg(h, k, kl, v, f) \
-	SvMAGICAL_off((SV *)(h)); \
-	hv_store((h), (k), (kl), (v), (f)); \
-	SvMAGICAL_on((SV *)(h))
+        SvMAGICAL_off((SV *)(h)); \
+        hv_store((h), (k), (kl), (v), (f)); \
+        SvMAGICAL_on((SV *)(h))
 
 //
 // This silly-looking key is what will be used on the RPM::Header and
@@ -95,4 +105,47 @@ typedef HV* RPM__Header;
 // This must match!
 #define STRUCT_KEY_LEN 13
 
+//
+// This struct will be used for RPM data type coming out of an RPM::Header
+// object. It will be implemented as a tied scalar, so we shouldn't need any
+// weird private-key voodoo like for the two previous.
+//
+
+typedef struct {
+    SV* value;    // May be an SV* or a ptr to an AV*
+    int size;     // Number of items
+    int type;     // Will match one of the RPM_*_TYPE values.
+} RPM_Header_datum;
+
+typedef RPM_Header_datum* RPM__Header__datum;
+
+#define new_RPM__Header__datum(x) Newz(TRUE, (x), 1, RPM_Header_datum)
+
+//
+// These represent the various interfaces that are allowed for use outside
+// their native modules.
+//
+// RPM.xs:
+extern int tag2num(const char *);
+extern const char* num2tag(int);
+extern void clear_errors(void);
+extern SV* set_error_callback(SV *);
+extern void rpm_error(int, const char *);
+
+// RPM/Header.xs:
+extern const char* sv2key(SV *);
+extern RPM__Header rpmhdr_TIEHASH(SV *, SV *, int);
+extern AV* rpmhdr_FETCH(RPM__Header, SV *, const char *, int, int);
+extern int rpmhdr_STORE(RPM__Header, SV *, AV *);
+extern int rpmhdr_DELETE(RPM__Header, SV *);
+extern int rpmhdr_EXISTS(RPM__Header, SV *);
+extern unsigned int rpmhdr_size(RPM__Header);
+extern int rpmhdr_tagtype(RPM__Header, SV *);
+extern int rpmhdr_write(RPM__Header, SV *, int);
+
+// RPM/Database.xs:
+extern RPM__Database rpmdb_TIEHASH(char *, SV *);
+extern RPM__Header rpmdb_FETCH(RPM__Database, SV *);
+extern int rpmdb_EXISTS(RPM__Database, SV *);
+
 #endif /* H_RPM_XS_HDR */
diff --git a/Perl-RPM/RPM.pm b/Perl-RPM/RPM.pm
index 9ab04e1ce..334bf2922 100644
--- a/Perl-RPM/RPM.pm
+++ b/Perl-RPM/RPM.pm
@@ -3,12 +3,17 @@ package RPM;
 use 5.005;
 use strict;
 use subs qw(bootstrap_Constants bootstrap_Header bootstrap_Database);
-use vars qw($VERSION @ISA);
+use vars qw($VERSION $revision @ISA @EXPORT @EXPORT_OK);
 
 require DynaLoader;
+require Exporter;
 
-@ISA = qw(DynaLoader);
-$VERSION = '0.1';
+@ISA = qw(Exporter DynaLoader);
+$VERSION = '0.2';
+$revision = do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
+
+@EXPORT = qw(GetOsName GetArchName);
+@EXPORT_OK = @EXPORT;
 
 bootstrap RPM $VERSION;
 
@@ -36,13 +41,41 @@ RPM - Perl interface to the API for the RPM Package Manager
 At present, the package-manipulation functionality is not yet implemented.
 The B<RPM::Database> and B<RPM::Header> packages do provide access to the
 information contained within the database of installed packages, and
-individual package headers, respectively.
+individual package headers, respectively. The B<RPM::Error> package is
+available, which provides support routines for signaling and catching
+errors. Additionally, there is the B<RPM::Constants> package which provides
+a number of values from the B<rpm> library, referred to by the same name used
+at the C level.
+
+=head1 UTILITY FUNCTIONS
+
+The following utility functions are exported by default from B<RPM>:
+
+=over
+
+=item GetOsName
+
+Returns the text name of the O/S, as derived from the B<rpm> configuration
+files. This is the O/S token that B<rpm> will use to refer to the running
+system.
+
+=item GetArchName
+
+As above, but returns the architecture string instead. Again, this may not
+directly match the running system, but rather is the value that B<rpm> is
+using. B<rpm> will use the lowest-matching architecture whenever possible,
+for maximum cross-platform compatibility.
+
+=back
 
 =head1 DIAGNOSTICS
 
-Direct binding to the internal error-management of B<rpm> is still under
-development. At present, most operations generate their diagnostics to
-STDERR.
+When an error occurs in either the C-level B<rpm> library or internally
+within these libraries, it is made available via a special dual-nature
+variable B<$RPM::err>. When evaluated in a numeric context, it returns the
+integer code value of the error. When taken in a string context, it returns
+the text message associated with the error. This is intended to closely
+mimic the behavior of the special Perl variable "C<$!>".
 
 =head1 CAVEATS
 
@@ -51,7 +84,8 @@ subject to change in future releases.
 
 =head1 SEE ALSO
 
-L<RPM::Database>, L<RPM::Header>, L<perl>, L<rpm>
+L<RPM::Constants>, L<RPM::Database>, L<RPM::Error>, L<RPM::Header>,
+L<perl>, L<rpm>
 
 =head1 AUTHOR
 
diff --git a/Perl-RPM/RPM.xs b/Perl-RPM/RPM.xs
index 8bb1eb4e8..fc944494f 100644
--- a/Perl-RPM/RPM.xs
+++ b/Perl-RPM/RPM.xs
@@ -4,7 +4,7 @@
 
 #include "RPM.h"
 
-static char * const rcsid = "$Id: RPM.xs,v 1.1 2000/05/22 08:37:45 rjray Exp $";
+static char * const rcsid = "$Id: RPM.xs,v 1.2 2000/05/27 05:22:51 rjray Exp $";
 
 extern XS(boot_RPM__Constants);
 extern XS(boot_RPM__Header);
@@ -12,8 +12,10 @@ extern XS(boot_RPM__Database);
 
 static HV* tag2num_priv;
 static HV* num2tag_priv;
+static SV* errSV;
+static CV* err_callback;
 
-void setup_tag_mappings(void)
+static void setup_tag_mappings(void)
 {
     const char* tag;
     int num;
@@ -40,17 +42,62 @@ void setup_tag_mappings(void)
     }
 }
 
+int tag2num(const char* tag)
+{
+    SV** svp;
+
+    // Get the #define value for the tag from the hash made at boot-up
+    svp = hv_fetch(tag2num_priv, (char *)tag, strlen(tag), FALSE);
+    if (! (svp && SvOK(*svp) && SvIOK(*svp)))
+        // Later we may need to set some sort of error message
+        return 0;
+
+    return (SvIV(*svp));
+}
+
+const char* num2tag(int num)
+{
+    SV** svp;
+    STRLEN na;
+    char str_num[8];
+    SV* tmp;
+
+    Zero(str_num, 1, 8);
+    snprintf(str_num, 8, "%d", num);
+    svp = hv_fetch(num2tag_priv, str_num, strlen(str_num), FALSE);
+    if (! (svp && SvPOK(*svp)))
+        return Nullch;
+
+    return (SvPV(*svp, na));
+}
+
+char* rpm_GetOsName(void)
+{
+    char* os_name;
+    int os_val;
+
+    rpmGetOsInfo((const char **)&os_name, &os_val);
+    return os_name;
+}
+
+char* rpm_GetArchName(void)
+{
+    char* arch_name;
+    int arch_val;
+
+    rpmGetArchInfo((const char **)&arch_name, &arch_val);
+    return arch_name;
+}
+
 // This is a callback routine that the bootstrapper will register with the RPM
 // lib so as to catch any errors. (I hope)
-void rpm_catch_errors_SV(void)
+static void rpm_catch_errors(void)
 {
-    SV* errSV;
     int error_code;
     char* error_string;
 
     error_code = rpmErrorCode();
     error_string = rpmErrorString();
-    errSV = perl_get_sv("RPM::err", GV_ADD|GV_ADDMULTI);
 
     // Set the string part, first
     sv_setsv(errSV, newSVpv(error_string, strlen(error_string)));
@@ -59,15 +106,34 @@ void rpm_catch_errors_SV(void)
     // Doing that didn't erase the PV part, but it cleared the flag:
     SvPOK_on(errSV);
 
+    // If there is a current callback, invoke it:
+    if (err_callback != NULL)
+    {
+        // This is just standard boilerplate for calling perl from C
+        dSP;
+        ENTER;
+        SAVETMPS;
+        PUSHMARK(sp);
+        XPUSHs(sv_2mortal(newSViv(error_code)));
+        XPUSHs(sv_2mortal(newSVpv(error_string, strlen(error_string))));
+        PUTBACK;
+
+        // The actual call
+        perl_call_sv((SV *)err_callback, G_DISCARD);
+
+        // More boilerplate
+        SPAGAIN;
+        PUTBACK;
+        FREETMPS;
+        LEAVE;
+    }
+
     return;
 }
 
 // This is just to make available an easy way to clear both sides of $RPM::err
-void rpm_clear_errors_SV(void)
+void clear_errors(void)
 {
-    SV* errSV;
-
-    errSV = perl_get_sv("RPM::err", GV_ADD|GV_ADDMULTI);
     sv_setsv(errSV, newSVpv("", 0));
     sv_setiv(errSV, 0);
     SvPOK_on(errSV);
@@ -75,43 +141,83 @@ void rpm_clear_errors_SV(void)
     return;
 }
 
-int tag2num(const char* tag)
+SV* set_error_callback(SV* newcb)
 {
-    SV** svp;
+    CV* oldcb;
 
-    // Get the #define value for the tag from the hash made at boot-up
-    svp = hv_fetch(tag2num_priv, (char *)tag, strlen(tag), FALSE);
-    if (! (svp && SvOK(*svp) && SvIOK(*svp)))
-        // Later we may need to set some sort of error message
-        return 0;
+    oldcb = err_callback;
 
-    return (SvIV(*svp));
+    if (SvROK(newcb)) newcb = SvRV(newcb);
+    if (SvTYPE(newcb) == SVt_PVCV)
+        err_callback = (CV *)newcb;
+    else if (SvPOK(newcb))
+    {
+        char* fn_name;
+        char* sv_name;
+        STRLEN len;
+
+        sv_name = SvPV(newcb, len);
+        if (! strstr(sv_name, "::"))
+        {
+            Newz(TRUE, fn_name, strlen(sv_name) + 7, char);
+            strncat(fn_name, "main::", 6);
+            strcat(fn_name + 6, sv_name);
+        }
+        else
+            fn_name = sv_name;
+
+        err_callback = perl_get_cv(fn_name, FALSE);
+    }
+    else
+    {
+        err_callback = Null(CV *);
+    }
+
+    return (SV *)oldcb;
 }
 
-const char* num2tag(int num)
+void rpm_error(int code, const char* message)
 {
-    SV** svp;
-    STRLEN na;
-    char str_num[8];
-    SV* tmp;
+    rpmError(code, (char *)message);
+}
 
-    Zero(str_num, 1, 8);
-    snprintf(str_num, 8, "%d", num);
-    svp = hv_fetch(num2tag_priv, str_num, strlen(str_num), FALSE);
-    if (! (svp && SvPOK(*svp)))
-        return Nullch;
 
-    return (SvPV(*svp, na));
-}
+MODULE = RPM            PACKAGE = RPM::Error           
 
 
-MODULE = RPM            PACKAGE = RPM           
-PROTOTYPES: DISABLE
+SV*
+set_error_callback(newcb)
+    SV* newcb;
+    PROTOTYPE: $
+
+void
+clear_errors()
+    PROTOTYPE:
+
+void
+rpm_error(code, message)
+    int code;
+    char* message;
+    PROTOTYPE: $$
+
+
+MODULE = RPM            PACKAGE = RPM           PREFIX = rpm_
+
+
+char*
+rpm_GetOsName()
+    PROTOTYPE:
+
+char*
+rpm_GetArchName()
+    PROTOTYPE:
+
 
 BOOT:
 {
     SV * config_loaded;
 
+    errSV = perl_get_sv("RPM::err", GV_ADD|GV_ADDMULTI);
     config_loaded = perl_get_sv("RPM::__config_loaded", GV_ADD|GV_ADDMULTI);
     if (! (SvOK(config_loaded) && SvTRUE(config_loaded)))
     {
@@ -120,7 +226,8 @@ BOOT:
     }
 
     setup_tag_mappings();
-    rpmErrorSetCallback(rpm_catch_errors_SV);
+    rpmErrorSetCallback(rpm_catch_errors);
+    err_callback = Null(CV *);
 
     newXS("RPM::bootstrap_Constants", boot_RPM__Constants, file);
     newXS("RPM::bootstrap_Header", boot_RPM__Header, file);
diff --git a/Perl-RPM/typemap b/Perl-RPM/typemap
index 0a592a223..35c0cb1af 100644
--- a/Perl-RPM/typemap
+++ b/Perl-RPM/typemap
@@ -6,6 +6,7 @@ const char *		T_PTROBJ
 RPM			T_PTROBJ
 RPM::Database		O_RPM_Database
 RPM::Header		O_RPM_Header
+RPM::Header::datum	T_PTROBJ
 
 #
 # The following mappings for O_HvRV are taken directly from Dean Roehrich's