perl/Git.xs

   1 /* By carefully stacking #includes here (even if WE don't really need them)
   2  * we strive to make the thing actually compile. Git header files aren't very
   3  * nice. Perl headers are one of the signs of the coming apocalypse. */
   4 #include <ctype.h>
   5 /* Ok, it hasn't been so bad so far. */
   6
   7 /* libgit interface */
   8 #include "../cache.h"
   9 #include "../exec_cmd.h"
  10
  11 #define die perlyshadow_die__
  12
  13 /* XS and Perl interface */
  14 #include "EXTERN.h"
  15 #include "perl.h"
  16 #include "XSUB.h"
  17
  18 #include "ppport.h"
  19
  20 #undef die
  21
  22
  23 static char *
  24 report_xs(const char *prefix, const char *err, va_list params)
  25 {
  26         static char buf[4096];
  27         strcpy(buf, prefix);
  28         vsnprintf(buf + strlen(prefix), 4096 - strlen(prefix), err, params);
  29         return buf;
  30 }
  31
  32 void
  33 die_xs(const char *err, va_list params)
  34 {
  35         char *str;
  36         str = report_xs("fatal: ", err, params);
  37         croak(str);
  38 }
  39
  40 int
  41 error_xs(const char *err, va_list params)
  42 {
  43         char *str;
  44         str = report_xs("error: ", err, params);
  45         warn(str);
  46         return -1;
  47 }
  48
  49
  50 MODULE = Git            PACKAGE = Git
  51
  52 PROTOTYPES: DISABLE
  53
  54
  55 BOOT:
  56 {
  57         set_error_routine(error_xs);
  58         set_die_routine(die_xs);
  59 }
  60
  61
  62 # /* TODO: xs_call_gate(). See Git.pm. */
  63
  64
  65 const char *
  66 xs_version()
  67 CODE:
  68 {
  69         RETVAL = GIT_VERSION;
  70 }
  71 OUTPUT:
  72         RETVAL
  73
  74
  75 const char *
  76 xs_exec_path()
  77 CODE:
  78 {
  79         RETVAL = git_exec_path();
  80 }
  81 OUTPUT:
  82         RETVAL
  83
  84
  85 void
  86 xs__execv_git_cmd(...)
  87 CODE:
  88 {
  89         const char **argv;
  90         int i;
  91
  92         argv = malloc(sizeof(const char *) * (items + 1));
  93         if (!argv)
  94                 croak("malloc failed");
  95         for (i = 0; i < items; i++)
  96                 argv[i] = strdup(SvPV_nolen(ST(i)));
  97         argv[i] = NULL;
  98
  99         execv_git_cmd(argv);
 100
 101         for (i = 0; i < items; i++)
 102                 if (argv[i])
 103                         free((char *) argv[i]);
 104         free((char **) argv);
 105 }
 106
 107 char *
 108 xs_hash_object(file, type = "blob")
 109         SV *file;
 110         char *type;
 111 CODE:
 112 {
 113         unsigned char sha1[20];
 114
 115         if (SvTYPE(file) == SVt_RV)
 116                 file = SvRV(file);
 117
 118         if (SvTYPE(file) == SVt_PVGV) {
 119                 /* Filehandle */
 120                 PerlIO *pio;
 121
 122                 pio = IoIFP(sv_2io(file));
 123                 if (!pio)
 124                         croak("You passed me something weird - a dir glob?");
 125                 /* XXX: I just hope PerlIO didn't read anything from it yet.
 126                  * --pasky */
 127                 if (index_pipe(sha1, PerlIO_fileno(pio), type, 0))
 128                         croak("Unable to hash given filehandle");
 129                 /* Avoid any nasty surprises. */
 130                 PerlIO_close(pio);
 131
 132         } else {
 133                 /* String */
 134                 char *path = SvPV_nolen(file);
 135                 int fd = open(path, O_RDONLY);
 136                 struct stat st;
 137
 138                 if (fd < 0 ||
 139                     fstat(fd, &st) < 0 ||
 140                     index_fd(sha1, fd, &st, 0, type))
 141                         croak("Unable to hash %s", path);
 142                 close(fd);
 143         }
 144         RETVAL = sha1_to_hex(sha1);
 145 }
 146 OUTPUT:
 147         RETVAL