ext/Text/Soundex/Soundex.xs

   1 /* -*- c -*- */
   2
   3 /* (c) Copyright 1998-2003 by Mark Mielke
   4  *
   5  * Freedom to use these sources for whatever you want, as long as credit
   6  * is given where credit is due, is hereby granted. You may make modifications
   7  * where you see fit but leave this copyright somewhere visible. As well try
   8  * to initial any changes you make so that if i like the changes i can
   9  * incorporate them into any later versions of mine.
  10  *
  11  *      - Mark Mielke <mark@mielke.cc>
  12  */
  13
  14 #include "EXTERN.h"
  15 #include "perl.h"
  16 #include "XSUB.h"
  17
  18 #define SOUNDEX_ACCURACY (4)    /* The maximum code length... (should be>=2) */
  19
  20 #if !(PERL_REVISION >= 5 && PERL_VERSION >= 8)
  21 #  define utf8n_to_uvchr utf8_to_uv
  22 #endif
  23
  24 static char *soundex_table =
  25   /*ABCDEFGHIJKLMNOPQRSTUVWXYZ*/
  26    "01230120022455012623010202";
  27
  28 static SV *sv_soundex (source)
  29      SV *source;
  30 {
  31   char *source_p;
  32   char *source_end;
  33
  34   {
  35     STRLEN source_len;
  36     source_p = SvPV(source, source_len);
  37     source_end = &source_p[source_len];
  38   }
  39
  40   while (source_p != source_end)
  41     {
  42       if ((*source_p & ~((UV) 0x7F)) == 0 && isalpha(*source_p))
  43         {
  44           SV   *code     = newSV(SOUNDEX_ACCURACY);
  45           char *code_p   = SvPVX(code);
  46           char *code_end = &code_p[SOUNDEX_ACCURACY];
  47           char  code_last;
  48
  49           SvCUR_set(code, SOUNDEX_ACCURACY);
  50           SvPOK_only(code);
  51
  52           code_last = soundex_table[(*code_p++ = toupper(*source_p++)) - 'A'];
  53
  54           while (source_p != source_end && code_p != code_end)
  55             {
  56               char c = *source_p++;
  57
  58               if ((c & ~((UV) 0x7F)) == 0 && isalpha(c))
  59                 {
  60                   *code_p = soundex_table[toupper(c) - 'A'];
  61                   if (*code_p != code_last && (code_last = *code_p) != '0')
  62                     code_p++;
  63                 }
  64             }
  65
  66           while (code_p != code_end)
  67             *code_p++ = '0';
  68
  69           *code_end = '\0';
  70
  71           return code;
  72         }
  73
  74       source_p++;
  75     }
  76
  77   return SvREFCNT_inc(perl_get_sv("Text::Soundex::nocode", FALSE));
  78 }
  79
  80 static SV *sv_soundex_utf8 (source)
  81      SV *source;
  82 {
  83   U8 *source_p;
  84   U8 *source_end;
  85
  86   {
  87     STRLEN source_len;
  88     source_p = (U8 *) SvPV(source, source_len);
  89     source_end = &source_p[source_len];
  90   }
  91
  92   while (source_p < source_end)
  93     {
  94       STRLEN offset;
  95       UV c = utf8n_to_uvchr(source_p, source_end-source_p, &offset, 0);
  96       source_p = (offset >= 1) ? &source_p[offset] : source_end;
  97
  98       if ((c & ~((UV) 0x7F)) == 0 && isalpha(c))
  99         {
 100           SV   *code     = newSV(SOUNDEX_ACCURACY);
 101           char *code_p   = SvPVX(code);
 102           char *code_end = &code_p[SOUNDEX_ACCURACY];
 103           char  code_last;
 104
 105           SvCUR_set(code, SOUNDEX_ACCURACY);
 106           SvPOK_only(code);
 107
 108           code_last = soundex_table[(*code_p++ = toupper(c)) - 'A'];
 109
 110           while (source_p != source_end && code_p != code_end)
 111             {
 112               c = utf8n_to_uvchr(source_p, source_end-source_p, &offset, 0);
 113               source_p = (offset >= 1) ? &source_p[offset] : source_end;
 114
 115               if ((c & ~((UV) 0x7F)) == 0 && isalpha(c))
 116                 {
 117                   *code_p = soundex_table[toupper(c) - 'A'];
 118                   if (*code_p != code_last && (code_last = *code_p) != '0')
 119                     code_p++;
 120                 }
 121             }
 122
 123           while (code_p != code_end)
 124             *code_p++ = '0';
 125
 126           *code_end = '\0';
 127
 128           return code;
 129         }
 130
 131       source_p++;
 132     }
 133
 134   return SvREFCNT_inc(perl_get_sv("Text::Soundex::nocode", FALSE));
 135 }
 136
 137 MODULE = Text::Soundex                          PACKAGE = Text::Soundex
 138
 139 PROTOTYPES: DISABLE
 140
 141 void
 142 soundex_xs (...)
 143 PPCODE:
 144 {
 145   int i;
 146   for (i = 0; i < items; i++)
 147     {
 148       SV *sv = ST(i);
 149
 150       if (DO_UTF8(sv))
 151         sv = sv_soundex_utf8(sv);
 152       else
 153         sv = sv_soundex(sv);
 154
 155       PUSHs(sv_2mortal(sv));
 156     }
 157 }