+ /* _mem_collxfrm() is a bit like strxfrm() but with two important
+ * differences. First, it handles embedded NULs. Second, it allocates a bit
+ * more memory than needed for the transformed data itself. The real
+ * transformed data begins at offset COLLXFRM_HDR_LEN. *xlen is set to
+ * the length of that, and doesn't include the collation index size.
+ * Please see sv_collxfrm() to see how this is used. */
+
+#define COLLXFRM_HDR_LEN sizeof(PL_collation_ix)
+
+ char * s = (char *) input_string;
+ STRLEN s_strlen = strlen(input_string);
+ char *xbuf = NULL;
+ STRLEN xAlloc; /* xalloc is a reserved word in VC */
+ STRLEN length_in_chars;
+ bool first_time = TRUE; /* Cleared after first loop iteration */
+
+ PERL_ARGS_ASSERT__MEM_COLLXFRM;
+
+ /* Must be NUL-terminated */
+ assert(*(input_string + len) == '\0');
+
+ /* If this locale has defective collation, skip */
+ if (PL_collxfrm_base == 0 && PL_collxfrm_mult == 0) {
+ goto bad;
+ }
+
+ /* Replace any embedded NULs with the control that sorts before any others.
+ * This will give as good as possible results on strings that don't
+ * otherwise contain that character, but otherwise there may be
+ * less-than-perfect results with that character and NUL. This is
+ * unavoidable unless we replace strxfrm with our own implementation.
+ *
+ * XXX This code may be overkill. khw wrote it before realizing that if
+ * you change a NUL into some other character, that that may change the
+ * strxfrm results if that character is part of a sequence with other
+ * characters for weight calculations. To minimize the chances of this,
+ * now the replacement is restricted to another control (likely to be
+ * \001). But the full generality has been retained.
+ *
+ * This is one of the few places in the perl core, where we can use
+ * standard functions like strlen() and strcat(). It's because we're
+ * looking for NULs. */
+ if (s_strlen < len) {
+ char * e = s + len;
+ char * sans_nuls;
+ STRLEN cur_min_char_len;
+
+ /* If we don't know what control character sorts lowest for this
+ * locale, find it */
+ if (*PL_strxfrm_min_char == '\0') {
+ int j;
+#ifdef DEBUGGING
+ U8 cur_min_cp = 1; /* The code point that sorts lowest, so far */
+#endif
+ char * cur_min_x = NULL; /* And its xfrm, (except it also
+ includes the collation index
+ prefixed. */
+
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Looking to replace NUL\n"));
+ /* Look through all legal code points (NUL isn't) */
+ for (j = 1; j < 256; j++) {
+ char * x; /* j's xfrm plus collation index */
+ STRLEN x_len; /* length of 'x' */
+ STRLEN trial_len = 1;
+
+ /* Create a 1 byte string of the current code point, but with
+ * room to be 2 bytes */
+ char cur_source[] = { (char) j, '\0' , '\0' };
+
+ if (PL_in_utf8_COLLATE_locale) {
+ if (! isCNTRL_L1(j)) {
+ continue;
+ }
+
+ /* If needs to be 2 bytes, find them */
+ if (! UVCHR_IS_INVARIANT(j)) {
+ char * d = cur_source;
+ append_utf8_from_native_byte((U8) j, (U8 **) &d);
+ trial_len = 2;
+ }
+ }
+ else if (! isCNTRL_LC(j)) {
+ continue;
+ }
+
+ /* Then transform it */
+ x = _mem_collxfrm(cur_source, trial_len, &x_len,
+ PL_in_utf8_COLLATE_locale);
+
+ /* If something went wrong (which it shouldn't), just
+ * ignore this code point */
+ if ( x_len == 0
+ || strlen(x + COLLXFRM_HDR_LEN) < x_len)
+ {
+ continue;
+ }
+
+ /* If this character's transformation is lower than
+ * the current lowest, this one becomes the lowest */
+ if ( cur_min_x == NULL
+ || strLT(x + COLLXFRM_HDR_LEN,
+ cur_min_x + COLLXFRM_HDR_LEN))
+ {
+ PL_strxfrm_min_char[0] = cur_source[0];
+ PL_strxfrm_min_char[1] = cur_source[1];
+ PL_strxfrm_min_char[2] = cur_source[2];
+ cur_min_x = x;
+#ifdef DEBUGGING
+ cur_min_cp = j;
+#endif
+ }
+ else {
+ Safefree(x);
+ }
+ } /* end of loop through all bytes */
+
+ /* Unlikely, but possible, if there aren't any controls in the
+ * locale, arbitrarily use \001 */
+ if (cur_min_x == NULL) {
+ STRLEN x_len; /* temporary */
+ cur_min_x = _mem_collxfrm("\001", 1, &x_len,
+ PL_in_utf8_COLLATE_locale);
+ /* cur_min_cp was already initialized to 1 */
+ }
+
+ DEBUG_L(PerlIO_printf(Perl_debug_log,
+ "_mem_collxfrm: lowest collating non-NUL control in the "
+ "0-255 range in locale %s is 0x%02X\n",
+ PL_collation_name,
+ cur_min_cp));
+ if (DEBUG_Lv_TEST) {
+ unsigned i;
+ PerlIO_printf(Perl_debug_log, "Its xfrm is");
+ for (i = 0; i < strlen(cur_min_x + COLLXFRM_HDR_LEN); i ++) {
+ PerlIO_printf(Perl_debug_log, " %02x",
+ (U8) *(cur_min_x + COLLXFRM_HDR_LEN + i));
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
+ }
+
+ Safefree(cur_min_x);
+ }
+
+ /* The worst case length for the replaced string would be if every
+ * character in it is NUL. Multiply that by the length of each
+ * replacement, and allow for a trailing NUL */
+ cur_min_char_len = strlen(PL_strxfrm_min_char);
+ Newx(sans_nuls, (len * cur_min_char_len) + 1, char);
+ *sans_nuls = '\0';
+
+
+ /* Replace each NUL with the lowest collating control. Loop until have
+ * exhausted all the NULs */
+ while (s + s_strlen < e) {
+ strcat(sans_nuls, s);
+
+ /* Do the actual replacement */
+ strcat(sans_nuls, PL_strxfrm_min_char);
+
+ /* Move past the input NUL */
+ s += s_strlen + 1;
+ s_strlen = strlen(s);
+ }