languages/tcl/src/binary.c

   1 /*
   2  * $Id$
   3  * Copyright (C) 2007, The Perl Foundation.
   4  */
   5
   6
   7 #include "parrot/parrot.h"
   8
   9 #include "binary.h"
  10 #include <stdio.h>
  11
  12 static int class_TclFloat  = 0;
  13 static int class_TclInt    = 0;
  14 static int class_TclList   = 0;
  15 static int class_TclString = 0;
  16
  17 /*
  18
  19 =head1 NAME
  20
  21 languages/tcl/src/binary.c
  22
  23 =head1 DESCRIPTION
  24
  25 RT#48162
  26
  27 =head2 Functions
  28
  29 =over 4
  30
  31 =item C<static int
  32 extract_int(char *str, int *pos, int length)>
  33
  34 Extract an integer from the string at the position given. Return the integer
  35 and update the position. Returns 1 if no digit is found or if the int is
  36 zero.
  37
  38 =cut
  39
  40 */
  41 static int
  42 extract_int(char *str, int *pos, int length)
  43 {
  44     int n = 0;
  45
  46     while (*pos < length && isdigit((unsigned char)str[*pos]))
  47         n = 10*n + (str[(*pos)++] - '0');
  48
  49     if (!n)
  50         n = 1;
  51
  52     return n;
  53 }
  54
  55 /*
  56
  57 =item C<static PMC *
  58 binary_scan_number_field(PARROT_INTERP, char field, char *binstr, int *_pos, int length)>
  59
  60 Scan and remove a number from a binary string. Return a PMC representing
  61 that value.
  62
  63 =cut
  64
  65  */
  66 static PMC *
  67 binary_scan_number_field(PARROT_INTERP, char field, char *binstr, int *_pos, int length)
  68 {
  69     char *c;
  70     double *d;
  71     float *f;
  72     int *n;
  73
  74     int len;
  75     PMC *value = NULL;
  76     int pos = *_pos;
  77     switch (field)
  78     {
  79         /* a char */
  80         case 'c':
  81             if (pos >= length)
  82                 break;
  83             c     = (char *)(binstr + pos);
  84             value = pmc_new(interp, class_TclInt);
  85             VTABLE_set_integer_native(interp, value, (INTVAL)*c);
  86             pos += 1;
  87             break;
  88         /* a double */
  89         case 'd':
  90             len = sizeof (double)/sizeof (char);
  91             if (pos + len > length)
  92                 break;
  93             d     = (double *)(binstr + pos);
  94             value = pmc_new(interp, class_TclFloat);
  95             VTABLE_set_number_native(interp, value, *d);
  96             pos += len;
  97             break;
  98         /* a float */
  99         case 'f':
 100             len = sizeof (float)/sizeof (char);
 101             if (pos + len > length)
 102                 break;
 103             f     = (float *)(binstr + pos);
 104             value = pmc_new(interp, class_TclFloat);
 105             VTABLE_set_number_native(interp, value, *f);
 106             pos += len;
 107             break;
 108         /* a native int */
 109         case 'n':
 110             len = sizeof (int)/sizeof (char);
 111             if (pos + len > length)
 112                 break;
 113             n     = (int *)(binstr + pos);
 114             value = pmc_new(interp, class_TclInt);
 115             VTABLE_set_integer_native(interp, value, *n);
 116             pos += len;
 117             break;
 118     }
 119     (*_pos) = pos;
 120     return value;
 121 }
 122
 123 /*
 124
 125 =item C<static PMC *
 126 binary_scan_number_slurpy(PARROT_INTERP, char field, char *binstr, int *_pos, int length)>
 127
 128 Scan the binary string for all remaining occurences of a number of the type
 129 of the field. Returns a TclList PMC of the number PMCs.
 130
 131 =cut
 132
 133  */
 134 static PMC *
 135 binary_scan_number_slurpy(PARROT_INTERP, char field, char *binstr, int *_pos, int length)
 136 {
 137     PMC *elem;
 138     PMC *values = pmc_new(interp, class_TclList);
 139
 140     while ((elem = binary_scan_number_field(interp, field, binstr, _pos, length)))
 141         VTABLE_push_pmc(interp, values, elem);
 142
 143     return values;
 144 }
 145
 146 /*
 147
 148 =item C<static PMC *
 149 binary_scan_number(PARROT_INTERP, char field,
 150                    char *format, int *formatpos, int formatlen,
 151                    char *binstr, int *binstrpos, int binstrlen)>
 152
 153 Scan the binary string for a number field. There may be a width following
 154 the field specifier.
 155
 156 =cut
 157
 158  */
 159 static PMC *
 160 binary_scan_number(PARROT_INTERP, char field,
 161                    char *format, int *formatpos, int formatlen,
 162                    char *binstr, int *binstrpos, int binstrlen)
 163 {
 164     PMC *value;
 165
 166     if ((*formatpos) < formatlen && format[*formatpos] == '*')
 167     {
 168         (*formatpos)++;
 169         value = binary_scan_number_slurpy(interp, field, binstr, binstrpos, binstrlen);
 170     }
 171     else
 172         value = binary_scan_number_field(interp, field, binstr, binstrpos, binstrlen);
 173
 174     return value;
 175 }
 176
 177 /*
 178
 179 =item C<static STRING *
 180 binary_scan_string_field(PARROT_INTERP, char field,
 181                          char *binstr, int *_binstrpos, int binstrlen,
 182                          STRING *value, int length)>
 183
 184 Scan the binary string for a string field. Returns the value of the extracted
 185 string (concatenated to its previous value).
 186
 187 =cut
 188
 189  */
 190 static STRING *
 191 binary_scan_string_field(PARROT_INTERP, char field,
 192                          char *binstr, int *_binstrpos, int binstrlen,
 193                          STRING *value, int length)
 194 {
 195     int binstrpos = *_binstrpos;
 196
 197     char *c;
 198     switch (field)
 199     {
 200         case 'a':
 201             if (binstrpos + length > binstrlen)
 202                 return NULL;
 203             c     = binstr + binstrpos;
 204             value = string_concat(interp, value, string_from_cstring(interp, c, length), 0);
 205             binstrpos += length;
 206             break;
 207         case 'A':
 208             if (binstrpos + length > binstrlen)
 209                 return NULL;
 210             c     = binstr + binstrpos;
 211             value = string_concat(interp, value, string_from_cstring(interp, c, length), 0);
 212             binstrpos += length;
 213             break;
 214         default:
 215             return NULL;
 216     }
 217
 218     *_binstrpos = binstrpos;
 219     return value;
 220 }
 221
 222 /*
 223
 224 =item C<static STRING *
 225 binary_scan_string_slurpy(PARROT_INTERP, char field,
 226                           char *binstr, int *_binstrpos, int binstrlen, STRING *value)>
 227
 228 Scan the binary string for all remaining matches of the field. Returns the
 229 new value of the STRING value passed in.
 230
 231 =cut
 232
 233  */
 234 static STRING *
 235 binary_scan_string_slurpy(PARROT_INTERP, char field,
 236                           char *binstr, int *_binstrpos, int binstrlen, STRING *value)
 237 {
 238     int length = string_length(interp, value);
 239     value      = binary_scan_string_field(interp, field,
 240                                           binstr, _binstrpos, binstrlen,
 241                                           value, length);
 242
 243     return value;
 244 }
 245
 246 /*
 247
 248 =item C<static PMC *
 249 binary_scan_string(PARROT_INTERP, char field,
 250                    char *format, int *formatpos, int formatlen,
 251                    char *binstr, int *binstrpos, int binstrlen)>
 252
 253 Scan the binary string for a string field. Returns a TclString PMC with the
 254 value(s) extracted.
 255
 256 =cut
 257
 258  */
 259 static PMC *
 260 binary_scan_string(PARROT_INTERP, char field,
 261                    char *format, int *formatpos, int formatlen,
 262                    char *binstr, int *binstrpos, int binstrlen)
 263 {
 264     STRING *value = string_make_empty(interp, enum_stringrep_one, 128);
 265     PMC *pmcval   = pmc_new(interp, class_TclString);
 266
 267     if ((*formatpos) < formatlen && format[*formatpos] == '*')
 268     {
 269         (*formatpos)++;
 270         value = binary_scan_string_slurpy(interp, field, binstr, binstrpos, binstrlen, value);
 271     }
 272     else
 273     {
 274         int n = extract_int(format, formatpos, formatlen);
 275         value = binary_scan_string_field(interp, field,
 276                                          binstr, binstrpos, binstrlen,
 277                                          value, n);
 278     }
 279
 280     VTABLE_set_string_native(interp, pmcval, value);
 281     return pmcval;
 282 }
 283
 284 /*
 285
 286 =item C<PMC *ParTcl_binary_scan(PARROT_INTERP, STRING *BINSTR, STRING *FORMAT)>
 287
 288 Scan a binary string according to a format string and return a TclList of
 289 the extracted values.
 290
 291 Assumes, in order to prevent entering another PIR runloop, that the format
 292 has been checked to contain valid fields.
 293
 294 String and number field code has been separated in an effort to reduce code.
 295
 296 =cut
 297
 298  */
 299 PMC *ParTcl_binary_scan(PARROT_INTERP, STRING *BINSTR, STRING *FORMAT)
 300 {
 301     char *binstr  = string_to_cstring(interp, BINSTR);
 302     int binstrlen = (int)string_length(interp, BINSTR);
 303     int binstrpos = 0;
 304     char *format  = string_to_cstring(interp, FORMAT);
 305     int formatlen = string_length(interp, FORMAT);
 306     int formatpos = 0;
 307     PMC *values;
 308
 309     /* make sure we've found the type numbers for the PMCs we want to create */
 310     if (!class_TclFloat)
 311     {
 312         class_TclFloat  = pmc_type(interp, string_from_literal(interp, "TclFloat"));
 313         class_TclInt    = pmc_type(interp, string_from_literal(interp, "TclInt"));
 314         class_TclList   = pmc_type(interp, string_from_literal(interp, "TclList"));
 315         class_TclString = pmc_type(interp, string_from_literal(interp, "TclString"));
 316     }
 317
 318     values = pmc_new(interp, class_TclList);
 319     while (formatpos < formatlen)
 320     {
 321         char field = format[formatpos++];
 322         PMC *value;
 323
 324         /* figure out if this is a number or a string field */
 325         switch (field)
 326         {
 327             case 'c':
 328             case 'd':
 329             case 'f':
 330             case 'n':
 331                 value = binary_scan_number(interp, field,
 332                                            format, &formatpos, formatlen,
 333                                            binstr, &binstrpos, binstrlen);
 334                 break;
 335             case 'a':
 336             case 'A':
 337                 value = binary_scan_string(interp, field,
 338                                            format, &formatpos, formatlen,
 339                                            binstr, &binstrpos, binstrlen);
 340                 break;
 341             default:
 342                 value = NULL;
 343                 break;
 344         }
 345
 346         VTABLE_push_pmc(interp, values, value);
 347     }
 348
 349     /* don't forget to free the strings we allocated */
 350     string_cstring_free(binstr);
 351     string_cstring_free(format);
 352
 353     return values;
 354 }
 355
 356 /*
 357
 358 =item C<static STRING *
 359 binary_format_number_field(PARROT_INTERP, char field, STRING *binstr, PMC *value)>
 360
 361 RT#48164: Not yet documented!!!
 362
 363 =cut
 364
 365 */
 366
 367 static STRING *
 368 binary_format_number_field(PARROT_INTERP, char field, STRING *binstr, PMC *value)
 369 {
 370     char c;
 371     double d;
 372     float f;
 373     int n;
 374
 375     INTVAL len;
 376
 377     switch (field)
 378     {
 379         /* a char */
 380         case 'c':
 381             c      = (char)VTABLE_get_integer(interp, value);
 382             binstr = string_concat(interp, binstr, string_from_cstring(interp, &c, 1), 0);
 383             break;
 384         /* a double */
 385         case 'd':
 386             d      = (double)VTABLE_get_number(interp, value);
 387             len    = sizeof (double)/sizeof (char);
 388             binstr = string_concat(interp, binstr, string_from_num(interp, (float)d), 0);
 389             break;
 390         /* a float */
 391         case 'f':
 392             f      = (float)VTABLE_get_number(interp, value);
 393             len    = sizeof (float)/sizeof (char);
 394             binstr = string_concat(interp, binstr, string_from_num(interp, f), 0);
 395             break;
 396         /* a native integer */
 397         case 'n':
 398             n      = (int)VTABLE_get_integer(interp, value);
 399             len    = sizeof (int)/sizeof (char);
 400             binstr = string_concat(interp, binstr, string_from_int(interp, n), 0);
 401             break;
 402     }
 403
 404     return binstr;
 405 }
 406
 407 /*
 408
 409 =item C<static STRING *
 410 binary_format_number(PARROT_INTERP, char field, STRING *binstr, PMC *value,
 411                      char *format, int *formatpos, int formatlen)>
 412
 413 RT#48164: Not yet documented!!!
 414
 415 =cut
 416
 417 */
 418
 419 static STRING *
 420 binary_format_number(PARROT_INTERP, char field, STRING *binstr, PMC *value,
 421                      char *format, int *formatpos, int formatlen)
 422 {
 423     binstr = binary_format_number_field(interp, field, binstr, value);
 424
 425     return binstr;
 426 }
 427
 428 /*
 429
 430 =item C<static STRING *
 431 binary_format_string_field(PARROT_INTERP, char field, STRING *binstr,
 432                            STRING *strval, int length)>
 433
 434 RT#48164: Not yet documented!!!
 435
 436 =cut
 437
 438 */
 439
 440 static STRING *
 441 binary_format_string_field(PARROT_INTERP, char field, STRING *binstr,
 442                            STRING *strval, int length)
 443 {
 444     int strlen = string_length(interp, strval);
 445
 446     switch (field)
 447     {
 448         case 'a':
 449             if (strlen > length)
 450                 string_chopn_inplace(interp, strval, strlen - length);
 451             binstr = string_concat(interp, binstr, strval, 0);
 452             /* pad with nulls if necessary */
 453             while (length-- > strlen)
 454                 binstr = string_concat(interp, binstr, string_from_cstring(interp, "", 1), 0);
 455             break;
 456         case 'A':
 457             if (strlen > length)
 458                 string_chopn_inplace(interp, strval, strlen - length);
 459             binstr = string_concat(interp, binstr, strval, 0);
 460             /* pad with spaces if necessary */
 461             while (length-- > strlen)
 462                 binstr = string_concat(interp, binstr, string_from_cstring(interp, " ", 1), 0);
 463             break;
 464     }
 465
 466     return binstr;
 467 }
 468
 469 /*
 470
 471 =item C<static STRING *
 472 binary_format_string(PARROT_INTERP, char field, STRING *binstr, PMC *value,
 473                      char *format, int *formatpos, int formatlen)>
 474
 475 RT#48164: Not yet documented!!!
 476
 477 =cut
 478
 479 */
 480
 481 static STRING *
 482 binary_format_string(PARROT_INTERP, char field, STRING *binstr, PMC *value,
 483                      char *format, int *formatpos, int formatlen)
 484 {
 485     STRING *strval = VTABLE_get_string(interp, value);
 486
 487     if ((*formatpos) < formatlen && format[*formatpos] == '*')
 488     {
 489         int len = string_length(interp, strval);
 490         binstr  = binary_format_string_field(interp, field, binstr, strval, len);
 491         (*formatpos)++;
 492     }
 493     else
 494     {
 495         int len = extract_int(format, formatpos, formatlen);
 496         binstr  = binary_format_string_field(interp, field, binstr, strval, len);
 497     }
 498
 499     return binstr;
 500 }
 501
 502 /*
 503
 504 =item C<STRING *ParTcl_binary_format(PARROT_INTERP, STRING *FORMAT, PMC *values)>
 505
 506 RT#48164: Not yet documented!!!
 507
 508 =cut
 509
 510 */
 511
 512 STRING *ParTcl_binary_format(PARROT_INTERP, STRING *FORMAT, PMC *values)
 513 {
 514     char *format   = string_to_cstring(interp, FORMAT);
 515     int formatlen  = string_length(interp, FORMAT);
 516     int formatpos  = 0;
 517     int valueidx   = 0;
 518     STRING *binstr = string_make_empty(interp, enum_stringrep_one, 128);
 519
 520     while (formatpos < formatlen)
 521     {
 522         char field = format[formatpos++];
 523         PMC *value = VTABLE_get_pmc_keyed_int(interp, values, valueidx++);
 524
 525         /* figure out if this is a number or a string field */
 526         switch (field)
 527         {
 528             case 'c':
 529             case 'd':
 530             case 'f':
 531             case 'n':
 532                 binstr = binary_format_number(interp, field, binstr, value,
 533                                               format, &formatpos, formatlen);
 534                 break;
 535             case 'a':
 536             case 'A':
 537                 binstr = binary_format_string(interp, field, binstr, value,
 538                                               format, &formatpos, formatlen);
 539                 break;
 540         }
 541     }
 542
 543     string_cstring_free(format);
 544
 545     return binstr;
 546 }
 547
 548 /*
 549
 550 =back
 551
 552 =cut
 553
 554 */
 555
 556 /*
 557  * Local variables:
 558  *   c-file-style: "parrot"
 559  * End:
 560  * vim: expandtab shiftwidth=4:
 561  */