obp/obp/pkg/netinet/strings.fth

\ ========== Copyright Header Begin ==========================================
\
\ Hypervisor Software File: strings.fth
\
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\
\  - Do no alter or remove copyright notices
\
\  - Redistribution and use of this software in source and binary forms, with
\    or without modification, are permitted provided that the following
\    conditions are met:
\
\  - Redistribution of source code must retain the above copyright notice,
\    this list of conditions and the following disclaimer.
\
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\    Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\
\     This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility.
\
\ ========== Copyright Header End ============================================
id: @(#)strings.fth 1.1 04/09/07
purpose: String utility functions
copyright: Copyright 2004 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

headerless

: null$ ( -- adr 0 ) " " ;

: byte-compare ( adr1 len1 adr2 len2 -- same? )
   rot tuck =  if  comp 0=  else  3drop false  then
;

\ Skip over 'n' characters in a string.
: /string ( adr len n -- adr' len' )  tuck - >r + r> ;

\ String compare.
: $=  ( adr1 len1 adr2 len2 -- same? )
   byte-compare
;

\ Case-insensitive string compare.
: $case= ( adr1 len1 adr2 len2 -- same? )
   rot tuck <>  if  3drop false exit  then              ( adr1 adr2 len1 )
   0  ?do
      over i ca+ c@ lcc  over i ca+ c@ lcc  <>  if
         2drop false unloop exit
      then
   loop
   2drop true
;

\ Decimal string to number conversion.
: $dnumber ( adr,len -- n false | true )
   base @ >r  decimal  $number  r> base !
;

\ Hexadecimal string to number conversion.
: $hnumber ( adr,len -- n false | true )
   base @ >r  hex  $number  r> base !
;

\ Return a pointer to the first occurence of a character in a string.
: strchr ( adr len char -- adr' )
   >r  over ca+  swap
   begin  2dup >  while
      dup c@  r@ =  if  nip r> drop exit  then  ca1+
   repeat
   r> 3drop 0
;

\ Locate the first occurence of a substring in a string. Returns a
\ pointer to the located substring, or 0 if the substring is not
\ found. If the substring is of zero length, a pointer to the
\ string will be returned.
: strstr ( str$ substr$ -- adr | 0 )
   2 pick over <  if                            ( adr len substr$ )
      2drop 2drop 0 exit                        ( 0 )
   then                                         ( adr len substr$ )
   rot over - 1+  0  ?do                        ( adr substr$ )
      3dup comp 0=  if                          ( adr substr$ )
         2drop unloop exit                      ( adr )
      then                                      ( adr substr$ )
      rot  ca1+  -rot                           ( adr' substr$ )
   loop                                         ( adr' substr$ )
   3drop 0                                      ( 0 )
;

\ Skip over all occurences of specified characters at the beginning
\ of the string.
: string-skipchars ( str$ chars$ -- str$' )
   2over bounds ?do                                     ( str$ chars$ )
      2dup i c@ strchr if                               ( str$ chars$ )
         2swap  1 /string  2swap                        ( str$' chars$ )
      else                                              ( str$ chars$ )
         leave                                          ( str$ chars$ )
      then                                              ( str$ chars$ )
   loop                                                 ( str$' chars$ )
   2drop                                                ( str$' )
;

\ Get the next token from the text string. Tokens are delimited by one
\ or more characters specified in the delimiter string.
: strtok ( text$ delim$ -- rem$ tok$ )
   2swap 2over  string-skipchars  2swap                 ( text$' delim$ )
   2over bounds ?do                                     ( text$' delim$ )
      2dup  i c@ strchr if                              ( text$' delim$ )
         2drop  i c@ left-parse-string unloop exit      ( rem$ tok$ )
      then                                              ( text$' delim$ )
   loop                                                 ( text$' delim$ )
   2drop null$ 2swap                                    ( null$ tok$ )
;

\ Split a string into 2 substrings.
: string-split ( adr len n -- adr+n len-n adr n )
   >r  2dup r@ /string  2swap drop r>
;

\ Get contents of a quoted string.
: qdstring>string ( $ -- $' )
   over c@ ascii " =  if
      1 /string  ascii " left-parse-string  2swap 2drop
   then
;

\ Concatenate strings.
: strcat ( adr1 len1 adr2 len2 -- adr1 len1+len2 )
   2over 2over 2swap ca+ swap move  nip +
;

\ Store string as a null-terminated string and return pointer past the
\ terminating null character.
: $cstrput ( str len dest-adr -- end-adr )
   swap  2dup ca+ >r  move  0 r@ c!  r> ca1+
;

: cstrlen ( cstr -- length )
   dup  begin  dup c@  while  ca1+  repeat  swap -
;

: cscount ( cstr -- adr len )  dup cstrlen ;

: upper ( adr len -- )  bounds  ?do  i dup c@ upc swap c!  loop ;
: lower ( adr len -- )  bounds  ?do  i dup c@ lcc swap c!  loop ;

d# 64  instance buffer:  hexascii-buf

\ Get ASCII hexadecimal representation of octet stream
: octet-to-hexascii ( data datalen -- buf buflen )
   hexascii-buf 0  2swap                                ( buf 0 data datalen )
   dup 0=  over d# 32 >  or  if                         ( buf 0 data datalen )
      2drop exit                                        ( buf 0 )
   then                                                 ( buf 0 data datalen )
   base @ >r  hex                                       ( buf 0 data datalen )
   bounds ?do                                           ( buf len )
      i c@  <# u# u# u#>                                ( buf len $ )
      2over ca+  swap move                              ( buf len )
      2+                                                ( buf len' )
   loop                                                 ( buf len' )
   2dup upper                                           ( buf len' )
   r> base !                                            ( buf buflen )
;

\ Get octet stream representation of ASCII hexadecimal string
: hexascii-to-octet ( data datalen -- buf buflen )
   hexascii-buf 0  2swap                                ( buf 0 data datalen )
   dup 0=  over d# 128 > or  over  2 mod 0<>  or if     ( buf 0 data datalen )
      2drop exit                                        ( buf 0 )
   then                                                 ( buf 0 data datalen )
   bounds ?do                                           ( buf len )
      i 2 $hnumber  if                                  ( buf len )
         drop 0 unloop exit                             ( buf 0 )
      then                                              ( buf len n )
      >r  2dup ca+  r> swap c!                          ( buf len )
      1+                                                ( buf len' )
   2 +loop                                              ( buf len' )
;

headers