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 static void NORETURN
  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 static void
  41 error_xs(const char *err, va_list params)
  42 {
  43         char *str;
  44         str = report_xs("error: ", err, params);
  45         warn(str);
  46 }
  47
  48
  49 MODULE = Git            PACKAGE = Git
  50
  51 PROTOTYPES: DISABLE
  52
  53
  54 BOOT:
  55 {
  56         set_error_routine(error_xs);
  57         set_die_routine(die_xs);
  58 }
  59
  60
  61 # /* TODO: xs_call_gate(). See Git.pm. */
  62
  63
  64 const char *
  65 xs_version()
  66 CODE:
  67 {
  68         RETVAL = GIT_VERSION;
  69 }
  70 OUTPUT:
  71         RETVAL
  72
  73
  74 const char *
  75 xs_exec_path()
  76 CODE:
  77 {
  78         RETVAL = git_exec_path();
  79 }
  80 OUTPUT:
  81         RETVAL
  82
  83
  84 void
  85 xs__execv_git_cmd(...)
  86 CODE:
  87 {
  88         const char **argv;
  89         int i;
  90
  91         argv = malloc(sizeof(const char *) * (items + 1));
  92         if (!argv)
  93                 croak("malloc failed");
  94         for (i = 0; i < items; i++)
  95                 argv[i] = strdup(SvPV_nolen(ST(i)));
  96         argv[i] = NULL;
  97
  98         execv_git_cmd(argv);
  99
 100         for (i = 0; i < items; i++)
 101                 if (argv[i])
 102                         free((char *) argv[i]);
 103         free((char **) argv);
 104 }
 105
 106 char *
 107 xs_hash_object(file, type = "blob")
 108         SV *file;
 109         char *type;
 110 CODE:
 111 {
 112         unsigned char sha1[20];
 113
 114         if (SvTYPE(file) == SVt_RV)
 115                 file = SvRV(file);
 116
 117         if (SvTYPE(file) == SVt_PVGV) {
 118                 /* Filehandle */
 119                 PerlIO *pio;
 120
 121                 pio = IoIFP(sv_2io(file));
 122                 if (!pio)
 123                         croak("You passed me something weird - a dir glob?");
 124                 /* XXX: I just hope PerlIO didn't read anything from it yet.
 125                  * --pasky */
 126                 if (index_pipe(sha1, PerlIO_fileno(pio), type, 0))
 127                         croak("Unable to hash given filehandle");
 128                 /* Avoid any nasty surprises. */
 129                 PerlIO_close(pio);
 130
 131         } else {
 132                 /* String */
 133                 char *path = SvPV_nolen(file);
 134                 int fd = open(path, O_RDONLY);
 135                 struct stat st;
 136
 137                 if (fd < 0 ||
 138                     fstat(fd, &st) < 0 ||
 139                     index_fd(sha1, fd, &st, 0, type))
 140                         croak("Unable to hash %s", path);
 141                 close(fd);
 142         }
 143         RETVAL = sha1_to_hex(sha1);
 144 }
 145 OUTPUT:
 146         RETVAL