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         default:
 119             break;
 120     }
 121     (*_pos) = pos;
 122     return value;
 123 }
 124
 125 /*
 126
 127 =item C<static PMC *
 128 binary_scan_number_slurpy(PARROT_INTERP, char field, char *binstr, int *_pos, int length)>
 129
 130 Scan the binary string for all remaining occurences of a number of the type
 131 of the field. Returns a TclList PMC of the number PMCs.
 132
 133 =cut
 134
 135  */
 136 static PMC *
 137 binary_scan_number_slurpy(PARROT_INTERP, char field, char *binstr, int *_pos, int length)
 138 {
 139     PMC *elem;
 140     PMC *values = pmc_new(interp, class_TclList);
 141
 142     while ((elem = binary_scan_number_field(interp, field, binstr, _pos, length)))
 143         VTABLE_push_pmc(interp, values, elem);
 144
 145     return values;
 146 }
 147
 148 /*
 149
 150 =item C<static PMC *
 151 binary_scan_number(PARROT_INTERP, char field,
 152                    char *format, int *formatpos, int formatlen,
 153                    char *binstr, int *binstrpos, int binstrlen)>
 154
 155 Scan the binary string for a number field. There may be a width following
 156 the field specifier.
 157
 158 =cut
 159
 160  */
 161 static PMC *
 162 binary_scan_number(PARROT_INTERP, char field,
 163                    char *format, int *formatpos, int formatlen,
 164                    char *binstr, int *binstrpos, int binstrlen)
 165 {
 166     PMC *value;
 167
 168     if ((*formatpos) < formatlen && format[*formatpos] == '*')
 169     {
 170         (*formatpos)++;
 171         value = binary_scan_number_slurpy(interp, field, binstr, binstrpos, binstrlen);
 172     }
 173     else
 174         value = binary_scan_number_field(interp, field, binstr, binstrpos, binstrlen);
 175
 176     return value;
 177 }
 178
 179 /*
 180
 181 =item C<static STRING *
 182 binary_scan_string_field(PARROT_INTERP, char field,
 183                          char *binstr, int *_binstrpos, int binstrlen,
 184                          STRING *value, int length)>
 185
 186 Scan the binary string for a string field. Returns the value of the extracted
 187 string (concatenated to its previous value).
 188
 189 =cut
 190
 191  */
 192 static STRING *
 193 binary_scan_string_field(PARROT_INTERP, char field,
 194                          char *binstr, int *_binstrpos, int binstrlen,
 195                          STRING *value, int length)
 196 {
 197     int binstrpos = *_binstrpos;
 198
 199     char *c;
 200     switch (field)
 201     {
 202         case 'a':
 203             if (binstrpos + length > binstrlen)
 204                 return NULL;
 205             c     = binstr + binstrpos;
 206             value = string_concat(interp, value, string_from_cstring(interp, c, length), 0);
 207             binstrpos += length;
 208             break;
 209         case 'A':
 210             if (binstrpos + length > binstrlen)
 211                 return NULL;
 212             c     = binstr + binstrpos;
 213             value = string_concat(interp, value, string_from_cstring(interp, c, length), 0);
 214             binstrpos += length;
 215             break;
 216         default:
 217             return NULL;
 218     }
 219
 220     *_binstrpos = binstrpos;
 221     return value;
 222 }
 223
 224 /*
 225
 226 =item C<static STRING *
 227 binary_scan_string_slurpy(PARROT_INTERP, char field,
 228                           char *binstr, int *_binstrpos, int binstrlen, STRING *value)>
 229
 230 Scan the binary string for all remaining matches of the field. Returns the
 231 new value of the STRING value passed in.
 232
 233 =cut
 234
 235  */
 236 static STRING *
 237 binary_scan_string_slurpy(PARROT_INTERP, char field,
 238                           char *binstr, int *_binstrpos, int binstrlen, STRING *value)
 239 {
 240     int length = string_length(interp, value);
 241     value      = binary_scan_string_field(interp, field,
 242                                           binstr, _binstrpos, binstrlen,
 243                                           value, length);
 244
 245     return value;
 246 }
 247
 248 /*
 249
 250 =item C<static PMC *
 251 binary_scan_string(PARROT_INTERP, char field,
 252                    char *format, int *formatpos, int formatlen,
 253                    char *binstr, int *binstrpos, int binstrlen)>
 254
 255 Scan the binary string for a string field. Returns a TclString PMC with the
 256 value(s) extracted.
 257
 258 =cut
 259
 260  */
 261 static PMC *
 262 binary_scan_string(PARROT_INTERP, char field,
 263                    char *format, int *formatpos, int formatlen,
 264                    char *binstr, int *binstrpos, int binstrlen)
 265 {
 266     STRING *value = string_make_empty(interp, enum_stringrep_one, 128);
 267     PMC *pmcval   = pmc_new(interp, class_TclString);
 268
 269     if ((*formatpos) < formatlen && format[*formatpos] == '*')
 270     {
 271         (*formatpos)++;
 272         value = binary_scan_string_slurpy(interp, field, binstr, binstrpos, binstrlen, value);
 273     }
 274     else
 275     {
 276         int n = extract_int(format, formatpos, formatlen);
 277         value = binary_scan_string_field(interp, field,
 278                                          binstr, binstrpos, binstrlen,
 279                                          value, n);
 280     }
 281
 282     VTABLE_set_string_native(interp, pmcval, value);
 283     return pmcval;
 284 }
 285
 286 /*
 287
 288 =item C<PMC *ParTcl_binary_scan(PARROT_INTERP, STRING *BINSTR, STRING *FORMAT)>
 289
 290 Scan a binary string according to a format string and return a TclList of
 291 the extracted values.
 292
 293 Assumes, in order to prevent entering another PIR runloop, that the format
 294 has been checked to contain valid fields.
 295
 296 String and number field code has been separated in an effort to reduce code.
 297
 298 =cut
 299
 300  */
 301 PMC *ParTcl_binary_scan(PARROT_INTERP, STRING *BINSTR, STRING *FORMAT)
 302 {
 303     char *binstr  = string_to_cstring(interp, BINSTR);
 304     int binstrlen = (int)string_length(interp, BINSTR);
 305     int binstrpos = 0;
 306     char *format  = string_to_cstring(interp, FORMAT);
 307     int formatlen = string_length(interp, FORMAT);
 308     int formatpos = 0;
 309     PMC *values;
 310
 311     /* make sure we've found the type numbers for the PMCs we want to create */
 312     if (!class_TclFloat)
 313     {
 314         class_TclFloat  = pmc_type(interp, string_from_literal(interp, "TclFloat"));
 315         class_TclInt    = pmc_type(interp, string_from_literal(interp, "TclInt"));
 316         class_TclList   = pmc_type(interp, string_from_literal(interp, "TclList"));
 317         class_TclString = pmc_type(interp, string_from_literal(interp, "TclString"));
 318     }
 319
 320     values = pmc_new(interp, class_TclList);
 321     while (formatpos < formatlen)
 322     {
 323         char field = format[formatpos++];
 324         PMC *value;
 325
 326         /* figure out if this is a number or a string field */
 327         switch (field)
 328         {
 329             case 'c':
 330             case 'd':
 331             case 'f':
 332             case 'n':
 333                 value = binary_scan_number(interp, field,
 334                                            format, &formatpos, formatlen,
 335                                            binstr, &binstrpos, binstrlen);
 336                 break;
 337             case 'a':
 338             case 'A':
 339                 value = binary_scan_string(interp, field,
 340                                            format, &formatpos, formatlen,
 341                                            binstr, &binstrpos, binstrlen);
 342                 break;
 343             default:
 344                 value = NULL;
 345                 break;
 346         }
 347
 348         VTABLE_push_pmc(interp, values, value);
 349     }
 350
 351     /* don't forget to free the strings we allocated */
 352     string_cstring_free(binstr);
 353     string_cstring_free(format);
 354
 355     return values;
 356 }
 357
 358 /*
 359
 360 =item C<static STRING *
 361 binary_format_number_field(PARROT_INTERP, char field, STRING *binstr, PMC *value)>
 362
 363 RT#48164: Not yet documented!!!
 364
 365 =cut
 366
 367 */
 368
 369 static STRING *
 370 binary_format_number_field(PARROT_INTERP, char field, STRING *binstr, PMC *value)
 371 {
 372     char c;
 373     double d;
 374     float f;
 375     int n;
 376
 377     INTVAL len;
 378
 379     switch (field)
 380     {
 381         /* a char */
 382         case 'c':
 383             c      = (char)VTABLE_get_integer(interp, value);
 384             binstr = string_concat(interp, binstr, string_from_cstring(interp, &c, 1), 0);
 385             break;
 386         /* a double */
 387         case 'd':
 388             d      = (double)VTABLE_get_number(interp, value);
 389             len    = sizeof (double)/sizeof (char);
 390             binstr = string_concat(interp, binstr, string_from_num(interp, (float)d), 0);
 391             break;
 392         /* a float */
 393         case 'f':
 394             f      = (float)VTABLE_get_number(interp, value);
 395             len    = sizeof (float)/sizeof (char);
 396             binstr = string_concat(interp, binstr, string_from_num(interp, f), 0);
 397             break;
 398         /* a native integer */
 399         case 'n':
 400             n      = (int)VTABLE_get_integer(interp, value);
 401             len    = sizeof (int)/sizeof (char);
 402             binstr = string_concat(interp, binstr, string_from_int(interp, n), 0);
 403             break;
 404         default:
 405             break;
 406     }
 407
 408     return binstr;
 409 }
 410
 411 /*
 412
 413 =item C<static STRING *
 414 binary_format_number(PARROT_INTERP, char field, STRING *binstr, PMC *value,
 415                      char *format, int *formatpos, int formatlen)>
 416
 417 RT#48164: Not yet documented!!!
 418
 419 =cut
 420
 421 */
 422
 423 static STRING *
 424 binary_format_number(PARROT_INTERP, char field, STRING *binstr, PMC *value,
 425                      char *format, int *formatpos, int formatlen)
 426 {
 427     binstr = binary_format_number_field(interp, field, binstr, value);
 428
 429     return binstr;
 430 }
 431
 432 /*
 433
 434 =item C<static STRING *
 435 binary_format_string_field(PARROT_INTERP, char field, STRING *binstr,
 436                            STRING *strval, int length)>
 437
 438 RT#48164: Not yet documented!!!
 439
 440 =cut
 441
 442 */
 443
 444 static STRING *
 445 binary_format_string_field(PARROT_INTERP, char field, STRING *binstr,
 446                            STRING *strval, int length)
 447 {
 448     int strlen = string_length(interp, strval);
 449
 450     switch (field)
 451     {
 452         case 'a':
 453             if (strlen > length)
 454                 string_chopn_inplace(interp, strval, strlen - length);
 455             binstr = string_concat(interp, binstr, strval, 0);
 456             /* pad with nulls if necessary */
 457             while (length-- > strlen)
 458                 binstr = string_concat(interp, binstr, string_from_cstring(interp, "", 1), 0);
 459             break;
 460         case 'A':
 461             if (strlen > length)
 462                 string_chopn_inplace(interp, strval, strlen - length);
 463             binstr = string_concat(interp, binstr, strval, 0);
 464             /* pad with spaces if necessary */
 465             while (length-- > strlen)
 466                 binstr = string_concat(interp, binstr, string_from_cstring(interp, " ", 1), 0);
 467             break;
 468         default:
 469             break;
 470     }
 471
 472     return binstr;
 473 }
 474
 475 /*
 476
 477 =item C<static STRING *
 478 binary_format_string(PARROT_INTERP, char field, STRING *binstr, PMC *value,
 479                      char *format, int *formatpos, int formatlen)>
 480
 481 RT#48164: Not yet documented!!!
 482
 483 =cut
 484
 485 */
 486
 487 static STRING *
 488 binary_format_string(PARROT_INTERP, char field, STRING *binstr, PMC *value,
 489                      char *format, int *formatpos, int formatlen)
 490 {
 491     STRING *strval = VTABLE_get_string(interp, value);
 492
 493     if ((*formatpos) < formatlen && format[*formatpos] == '*')
 494     {
 495         int len = string_length(interp, strval);
 496         binstr  = binary_format_string_field(interp, field, binstr, strval, len);
 497         (*formatpos)++;
 498     }
 499     else
 500     {
 501         int len = extract_int(format, formatpos, formatlen);
 502         binstr  = binary_format_string_field(interp, field, binstr, strval, len);
 503     }
 504
 505     return binstr;
 506 }
 507
 508 /*
 509
 510 =item C<STRING *ParTcl_binary_format(PARROT_INTERP, STRING *FORMAT, PMC *values)>
 511
 512 RT#48164: Not yet documented!!!
 513
 514 =cut
 515
 516 */
 517
 518 STRING *ParTcl_binary_format(PARROT_INTERP, STRING *FORMAT, PMC *values)
 519 {
 520     char *format   = string_to_cstring(interp, FORMAT);
 521     int formatlen  = string_length(interp, FORMAT);
 522     int formatpos  = 0;
 523     int valueidx   = 0;
 524     STRING *binstr = string_make_empty(interp, enum_stringrep_one, 128);
 525
 526     while (formatpos < formatlen)
 527     {
 528         char field = format[formatpos++];
 529         PMC *value = VTABLE_get_pmc_keyed_int(interp, values, valueidx++);
 530
 531         /* figure out if this is a number or a string field */
 532         switch (field)
 533         {
 534             case 'c':
 535             case 'd':
 536             case 'f':
 537             case 'n':
 538                 binstr = binary_format_number(interp, field, binstr, value,
 539                                               format, &formatpos, formatlen);
 540                 break;
 541             case 'a':
 542             case 'A':
 543                 binstr = binary_format_string(interp, field, binstr, value,
 544                                               format, &formatpos, formatlen);
 545                 break;
 546         default:
 547             break;
 548         }
 549     }
 550
 551     string_cstring_free(format);
 552
 553     return binstr;
 554 }
 555
 556 /*
 557
 558 =back
 559
 560 =cut
 561
 562 */
 563
 564 /*
 565  * Local variables:
 566  *   c-file-style: "parrot"
 567  * End:
 568  * vim: expandtab shiftwidth=4:
 569  */