MT Pick Strings : Source

Source

--- This source is written in HyperTalk for CompileIt!

global myType:OStype, mySize:longInt, myactSize:longInt
global sstractSize:LongInt,estractSize:LongInt
global myCaseFlg:BooleanType
global theAEEvent:R,theReply:R, handerRefCon:LongInt
global ssPos:LongInt, edPos:LongInt

codeResource "osax"

pascal function pickString:I theAEEvent:R, theReply:R, handerRefCon:L

  put NewPtrClear(334) into myWorkPtr
  put myWorkPtr into myDescPtr
  put myWorkPtr + 8 into myFssPtr
  put myWorkPtr + 78 into myNmPtr

  put AEGetParamDesc(theAEEvent@,"csen",typeBoolean,myDescPtr@) into err
  if myDescPtr@.descriptorType = typeNull then
    put false into myCaseFlg
  else
    put myDescPtr@.dataHandle@@.booleanType into myCaseFlg
  end if
  put AEDisposeDesc(myDescPtr@) into xErr

  ---

  put AEGetParamDesc(theAEEvent@,"trim",typeBoolean,myDescPtr@) into err
  if myDescPtr@.descriptorType = typeNull then
    put false into myTrimFlg
  else
    put myDescPtr@.dataHandle@@.booleanType into myTrimFlg
  end if
  put AEDisposeDesc(myDescPtr@) into xErr

  ---

  put AEGetParamDesc(theAEEvent@,"sstr","TEXT",myDescPtr@) into err
  if err <> 0 then
    DisposPtr myWorkPtr
    return err
  end if

  put myDescPtr@.dataHandle into mysstrHandle
  put HandToHand(mysstrHandle) into err
  put AEDisposeDesc(myDescPtr@) into xErr
  if err <> 0 then
    DisposPtr myWorkPtr
    return err
  end if

  put GetHandleSize(mysstrHandle) into sstractSize
  if sstractSize = 0 then
    DisposHandle mysstrHandle
    DisposPtr myWorkPtr
    return -1701
  end if
  ---
  put AEGetParamDesc(theAEEvent@,"estr","TEXT",myDescPtr@) into err
  if err <> 0 then
    DisposHandle mysstrHandle
    DisposPtr myWorkPtr
    return err
  end if

  put myDescPtr@.dataHandle into myestrHandle
  put HandToHand(myestrHandle) into err
  put AEDisposeDesc(myDescPtr@) into xErr
  if err <> 0 then
    DisposHandle mysstrHandle
    DisposPtr myWorkPtr
    return err
  end if

  put GetHandleSize(myestrHandle) into estractSize
  if estractSize = 0 then
    DisposHandle myestrHandle
    DisposHandle mysstrHandle
    DisposPtr myWorkPtr
    return -1701
  end if
  ----

  put AEGetParamDesc(theAEEvent@,keyDirectObject,"TEXT",myDescPtr@) into err
  if err = 0 then
    put myDescPtr@.dataHandle into myStrHandle
    put HandToHand(myStrHandle) into err
    put AEDisposeDesc(myDescPtr@) into xErr
    if err <> 0 then
      DisposHandle myestrHandle
      DisposHandle mysstrHandle
      DisposPtr myWorkPtr
      return err
    end if

  else
    --- source param

    put AESizeOfParam(theAEEvent@,"scfl",myType,mySize) into err
    if err <> 0 then
      DisposHandle myestrHandle
      DisposHandle mysstrHandle
      DisposPtr myWorkPtr
      return err
    end if

    if myType = "TEXT" and mySize < 256 then

      put myNmPtr+1 into aPtr
      put AEGetParamPtr(theAEEvent@,"scfl","TEXT",typeCode,aPtr,mySize,myactSize) into err
      if err <> 0 then
        DisposHandle myestrHandle
        DisposHandle mysstrHandle
        DisposPtr myWorkPtr
        return err
      end if

      put NumToChar(mySize) into myNmPtr@.charType
      put myNmPtr@.Str255Type into myFname
      put FSMakeFSSpec(0, 0, myFname, myFssPtr@) into err
      if err <> 0 then
        DisposHandle myestrHandle
        DisposHandle mysstrHandle
        DisposPtr myWorkPtr
        return err
      end if

    else

      put AEGetParamPtr(theAEEvent@,"scfl",typeFSS,typeCode,myFssPtr,70,myactSize) into err
      if err <> 0 then
        DisposHandle myestrHandle
        DisposHandle mysstrHandle
        DisposPtr myWorkPtr
        return err
      end if

    end if

    put FSpOpenDF(myFssPtr@,fsCurPerm,myRefNum) into err
    if err <> 0 then
      DisposHandle myestrHandle
      DisposHandle mysstrHandle
      DisposPtr myWorkPtr
      return err
    end if

    get GetEOF(myRefNum,myBufSize)
    put MaxMem(dum) into myMemSize

    if myBufSize > (myMemSize-20480) then
      put FSClose(myRefNum) into err
      DisposHandle myestrHandle
      DisposHandle mysstrHandle
      DisposPtr myWorkPtr
      return -108
    end if

    put NewHandle(myBufSize) into myStrHandle
    put MemError() into err
    if myStrHandle = nil or err <> 0 then
      put FSClose(myRefNum) into err
      DisposHandle myestrHandle
      DisposHandle mysstrHandle
      DisposPtr myWorkPtr
      return err
    end if

    HLock myStrHandle
    put SetFPos(myRefNum,1,0) into err
    put FSRead(myRefNum,myBufSize,myStrHandle@) into Rerr
    put FSClose(myRefNum) into err
    HUnlock myStrHandle
    if Rerr <> 0 then
      DisposHandle myStrHandle
      DisposHandle myestrHandle
      DisposHandle mysstrHandle
      DisposPtr myWorkPtr
      return Rerr
    end if

  end if
  ----
  put AEcreateList(nil,0,false,myDescPtr@) into err
  if err <> 0 then
    DisposHandle myStrHandle
    DisposHandle myestrHandle
    DisposHandle mysstrHandle
    DisposPtr myWorkPtr
    return err
  end if
  ----

  put GetHandleSize(myStrHandle) into myBufSize

  if myBufSize = 0 then
    if theReply@.descriptorType <> typeNull then
      put AEPutParamDesc(theReply@, keyDirectObject,myDescPtr@) into err
    end if
    put AEDisposeDesc(myDescPtr@) into xErr
    DisposHandle myStrHandle
    DisposHandle myestrHandle
    DisposHandle mysstrHandle
    DisposPtr myWorkPtr
    return 0
  end if
  ----

  put 0 into baseOff
  put charToNum(mysstrHandle@@.charType[0]) into tgsA
  put charToNum(myestrHandle@@.charType[0]) into tgeA
  put myBufSize-1 into ckLen
  put sstractSize-1 into xsstLen
  put estractSize-1 into xestLen


  repeat

    put -1 into ssPos

    repeat with x = baseOff to (ckLen-sstractSize)
      put charToNum(myStrHandle@@.charType[x]) into tgB

      if EqualCase(tgsA,tgB) then
        put 0 into checkSum

        if xsstLen > 0 then
          repeat with y = xsstLen down to 1
            put charToNum(mysstrHandle@@.charType[y]) into ztgA
            put charToNum(myStrHandle@@.charType[x+y]) into ztgB
            if EqualCase(ztgA,ztgB) then next repeat
            add 1 to checkSum
            exit repeat
          end repeat
        end if

        if checkSum = 0 then
          put x into ssPos
          exit repeat
        end if

      end if
    end repeat

    if ssPos >= baseOff then
      put -1 into edPos

      repeat with x = (ssPos+sstractSize) to ((ckLen-estractSize)+1)
        put charToNum(myStrHandle@@.charType[x]) into tgB
        if EqualCase(tgeA,tgB) then
          put 0 into checkSum

          if xestLen > 0 then
            repeat with y = xestLen down to 1
              put charToNum(myestrHandle@@.charType[y]) into ztgA
              put charToNum(myStrHandle@@.charType[x+y]) into ztgB
              if EqualCase(ztgA,ztgB) then next repeat
              add 1 to checkSum
              exit repeat
            end repeat
          end if

          if checkSum = 0 then
            put x into edPos
            exit repeat
          end if
        end if
      end repeat

      if edPos >= 0 then

        Hlock myStrHandle

        if myTrimFlg then
          put edPos-ssPos-sstractSize into tgLen
          put myStrHandle@+ssPos+sstractSize into tgPtr
        else
          put edPos+estractSize-ssPos into tgLen
          put myStrHandle@+ssPos into tgPtr
        end if

        put AEPutPtr(myDescPtr@,0,typeChar,tgPtr,tgLen) into err
        if err <> 0 then
          Hunlock myStrHandle
          put AEDisposeDesc(myDescPtr@) into xerr
          DisposPtr myWorkPtr
          DisposHandle myStrHandle
          DisposHandle myestrHandle
          DisposHandle mysstrHandle
          return err
        end if

        Hunlock myStrHandle

        put edPos+estractSize into baseOff
        if baseOff+sstractSize < ckLen then
          next repeat
        end if

      end if
    end if

    exit repeat

  end repeat

  if theReply@.descriptorType <> typeNull then
    put AEPutParamDesc(theReply@, keyDirectObject,myDescPtr@) into err
  end if

  put AEDisposeDesc(myDescPtr@) into xErr

  DisposPtr myWorkPtr
  DisposHandle myStrHandle
  DisposHandle myestrHandle
  DisposHandle mysstrHandle


  return err

end pickString


function EqualCase tgA, tgB
  if myCaseFlg then
    return (tgA = tgB)
  end if

  if tgA >= 65 and tgA <= 90 then put tgA+32 into tgA
  if tgB >= 65 and tgB <= 90 then put tgB+32 into tgB
  return (tgA = tgB)

end EqualCase