This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move Text::Soundex from lib/ to ext/ and upgrade it to
[perl5.git] / 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 }