Power-Programmierung/CD1.mdf/pascal/library/dos/help/tphelp/makehelp.pas

Pascal/Delphi Source File | 1988-02-01 | 13.0 KB | 507 lines

{BLDHELP.PAS Copyright (C) 1988, by TurboPower Software}

{$R-,S-,I-,V-}

PROGRAM BuildHelp;
  {-Build indexed binary help file from text file}
Uses
  Dos,
  TPDos,
  TPString,
  TPCrt,
  TPWindow,
  TPHelp;

CONST
  FileBuffSize = 4096;       {Size of input and output file buffers}
  CommandMark = '!';         {Marks help metacommand in text file}
  CommentMark = ';';         {At start of line, marks comment in text file}

TYPE
  FileBuff = ARRAY[1..FileBuffSize] OF CHAR;
  String80 = STRING[80];

VAR
  InName : String80;         {Input file name}
  OutName : String80;        {Output file name}
  InF : TEXT;                {Input file}
  OutF : FILE;               {Output file}
  InBuff : FileBuff;         {Buffer for input text}
  OutBuff : FileBuff;        {Buffer for binary output}
  OutPos : Word;             {Bytes used in output buffer}

  Hdr : HelpHeader;          {Header of help file}
  CP : CharArrayPtr;         {Points to pick array}
  Hi : HelpIndexPtr;         {Points to help index}

  C : String80;              {Command or command parameter}
  S : STRING;                {Raw input line}
  Spos : Byte;               {Position in input line}
  LineNum : LongInt;         {Current input line number}
  SectPos : LongInt;         {File offset of current section}
  TextWid : Byte;            {Max characters in a line}
  CurSect : Word;            {Current section number}
  LineLen : Byte;            {Current line width}
  SectLen : Word;            {Bytes in current section}

  PROCEDURE Error(Msg : STRING);
    {-Write error message and halt}
  BEGIN
    WRITELN(Msg);
    HALT(1);
  END;

  PROCEDURE ErrorLine(Msg : STRING);
    {-Report error position and message}
  VAR
    IO : Word;
  BEGIN
    WRITELN(^M'Line number: ', LineNum);
    WRITELN(S);
    CLOSE(OutF);
    Erase(OutF);
    IO := IOResult;
    Error(Msg);
  END;

  PROCEDURE ErrorOut;
    {-Report output writing error}
  BEGIN
    Error('Error writing to '+OutName);
  END;

  PROCEDURE UpdateLineNum;
    {-Increment counter and update status display}
  BEGIN
    Inc(LineNum);
    IF LineNum AND $F = 0 THEN
      WRITE(^M, LineNum);
  END;

  PROCEDURE Initialize;
    {-Prepare for analysis of help file}
  BEGIN
    {Open the files}
    IF ParamCount <> 2 THEN
      Error('Usage: BLDHELP InFile OutFile');
    InName := stupcase(CleanPathName(ParamStr(1)));
    OutName := stupcase(CleanPathName(ParamStr(2)));
    ASSIGN(InF, InName);
    RESET(InF);
    IF IOResult <> 0 THEN
      Error(InName+' not found');
    SetTextBuf(InF, InBuff, FileBuffSize);
    ASSIGN(OutF, OutName);
    REWRITE(OutF, 1);
    IF IOResult <> 0 THEN
      Error('Cannot create '+OutName);

    {Default help header}
    WITH Hdr DO BEGIN
      ID := LongInt(HelpId);
      MaxSection := 0;
      ItemCnt := 0;
      NameSize := 0;
      Width := 40;
    END;
  END;

  {$F+}
  FUNCTION HeapFunc(Size : Word) : INTEGER;
    {-Return nil pointer if insufficient memory}
  BEGIN
    HeapFunc := 1;
  END;
  {$F-}

  FUNCTION GetMemCheck(VAR P; Bytes : Word) : BOOLEAN;
    {-Allocate heap space, returning true if successful}
  VAR
    SaveHeapError : Pointer;
    Pt : Pointer Absolute P;
  BEGIN
    {Take over heap error control}
    SaveHeapError := HeapError;
    HeapError := @HeapFunc;
    GetMem(Pt, Bytes);
    GetMemCheck := (Pt <> NIL);
    {Restore heap error control}
    HeapError := SaveHeapError;
  END;

  PROCEDURE SkipWhite(VAR S : STRING; VAR Spos : Byte);
    {-Advance Spos past white space}
  BEGIN
    WHILE (Spos <= LENGTH(S)) AND (S[Spos] <= ' ') DO
      Inc(Spos);
  END;

  PROCEDURE ParseWord(VAR S : STRING; VAR Spos : Byte; VAR C : STRING; MaxLen : Byte);
    {-Parse next word from S, returning it in C}
  VAR
    Clen : Byte Absolute C;
  BEGIN
    SkipWhite(S, Spos);
    Clen := 0;
    WHILE (Spos <= LENGTH(S)) AND (S[Spos] > ' ') DO BEGIN
      IF Clen < MaxLen THEN BEGIN
        Inc(Clen);
        C[Clen] := S[Spos];
      END;
      Inc(Spos);
    END;
  END;

  FUNCTION ParseNumber(VAR S : STRING; VAR Spos : Byte; Name : STRING) : Word;
    {-Parse a word from the line}
  VAR
    C : STRING[8];
    N : Word;
  BEGIN
    ParseWord(S, Spos, C, 8);
    IF LENGTH(C) = 0 THEN
      ErrorLine(Name+' expected');
    IF NOT Str2Word(C, N) THEN
      ErrorLine('Invalid '+Name+' specified');
    ParseNumber := N;
  END;

  PROCEDURE ParseColors(VAR S : STRING; VAR Spos : Byte; VAR Attr : HelpAttrArray);
    {-Store new color set}
  VAR
    A : HelpAttrType;
  BEGIN
    FOR A := FrAttr TO SpAtt3 DO
      Attr[A] := ParseNumber(S, Spos, 'Color');
  END;

  FUNCTION ClassifyCommand(C : STRING) : Word;
    {-Classify valid help metacommands}
  CONST
    NumCommands = 4;
    CommandNames : ARRAY[1..NumCommands] OF STRING[5] =
    ('TOPIC', 'LINE', 'PAGE', 'WIDTH');
  VAR
    I : INTEGER;
  BEGIN
    C := stupcase(C);
    FOR I := 1 TO NumCommands DO
      IF C = CommandNames[I] THEN BEGIN
        ClassifyCommand := I;
        Exit;
      END;
    ClassifyCommand := 0;
  END;

  FUNCTION BlockWriteOK(VAR B; Bytes : Word) : BOOLEAN;
    {-Write a block to output and error check}
  VAR
    BytesWritten : Word;
  BEGIN
    BlockWrite(OutF, B, Bytes, BytesWritten);
    BlockWriteOK := (IOResult = 0) AND (BytesWritten = Bytes);
  END;

  PROCEDURE WriteHeaders;
    {-Write the binary header structures to the help file}
  BEGIN
    WITH Hdr DO BEGIN
      IF NOT BlockWriteOK(Hdr, SIZEOF(HelpHeader)) THEN
        ErrorOut;
      IF NOT BlockWriteOK(CP^, ItemCnt*NameSize) THEN
        ErrorOut;
      IF NOT BlockWriteOK(Hi^, ItemCnt*SIZEOF(LongInt)) THEN
        ErrorOut;
      {Store position for first help section}
      SectPos := SIZEOF(HelpHeader)+ItemCnt*(NameSize+SIZEOF(LongInt));
    END;
  END;

  PROCEDURE CountFile;
    {-Scan input file once to determine number of items}
  BEGIN
    WITH Hdr DO BEGIN
      LineNum := 0;

      WHILE NOT EOF(InF) DO BEGIN
        READLN(InF, S);
        UpdateLineNum;

        IF (LENGTH(S) > 0) AND (S[1] = CommandMark) THEN BEGIN
          {Line is a help metacommand}
          Spos := 2;
          ParseWord(S, Spos, C, 8);
          CASE ClassifyCommand(C) OF
            1 :              {TOPIC}
              BEGIN
                {New section, get section number}
                CurSect := ParseNumber(S, Spos, 'Topic number');
                IF CurSect > ItemCnt THEN
                  ItemCnt := CurSect;
                {Get optional pick name}
                SkipWhite(S, Spos);
                C := COPY(S, Spos, 64);
                IF LENGTH(C)+1 > NameSize THEN
                  NameSize := LENGTH(C)+1;
              END;
            {Ignore other metacommands this pass}
          END;
        END;
      END;

      {Clear the status}
      WRITE(^M'         '^M);
      {Allocate space for name and index arrays}
      IF ItemCnt = 0 THEN
        Error('No help topics specified');

      IF NameSize = 0 THEN
        CP := NIL
      ELSE IF LongInt(ItemCnt)*NameSize > 65520 THEN
        Error('Pick name array exceeds 64K')
      ELSE IF NOT GetMemCheck(CP, ItemCnt*NameSize) THEN
        Error('Insufficient memory for name array');

      IF NOT GetMemCheck(Hi, ItemCnt*SIZEOF(LongInt)) THEN
        Error('Insufficient memory for index array');

      {Initialize the arrays}
      FillChar(CP^, ItemCnt*NameSize, 0);
      FillChar(Hi^, ItemCnt*SIZEOF(LongInt), Lo(NoHelpAvailable));

      {Reserve disk space for initial binary help structures}
      WriteHeaders;
    END;
  END;

  PROCEDURE FlushBuffer;
    {-Write the output buffer to file}
  BEGIN
    IF OutPos > 0 THEN BEGIN
      IF NOT BlockWriteOK(OutBuff, OutPos) THEN
        ErrorOut;
      OutPos := 0;
    END;
  END;

  PROCEDURE CharOut(Ch : CHAR);
    {-Write a single character to output (with buffering)}
  BEGIN
    IF OutPos >= FileBuffSize THEN
      FlushBuffer;
    Inc(OutPos);
    OutBuff[OutPos] := Ch;
    Inc(SectLen);
  END;

  PROCEDURE NewSection;
    {-End the current section and prepare for the new}
  BEGIN
    CharOut(SectEndMark);
    Inc(SectPos, SectLen);
    WITH Hdr DO
      IF SectLen > MaxSection THEN
        MaxSection := SectLen;
    SectLen := 0;
    LineLen := 0;
  END;

  PROCEDURE NewPage;
    {-End the current page}
  BEGIN
    CharOut(PageBrkMark);
    LineLen := 0;
  END;

  PROCEDURE NewLine;
    {-End the current line}
  BEGIN
    CharOut(LineBrkMark);
    LineLen := 0;
  END;

  PROCEDURE StorePickName(C : STRING);
    {-Store pick name for CurSect}
  BEGIN
    WITH Hdr DO
      Move(C, CP^[(CurSect-1)*NameSize], LENGTH(C)+1);
  END;

  FUNCTION LenCount(Ch : CHAR) : Byte;
    {-Return length to count for character}
  BEGIN
    CASE Ch OF
      Attr1Toggle,
      Attr2Toggle,
      Attr3Toggle :
        LenCount := 0;
    ELSE
      LenCount := 1;
    END;
  END;

  PROCEDURE LineOut;
    {-Wrap and write text lines}
  VAR
    Tpos : Byte;
    Tlen : Byte;
  BEGIN
    IF LENGTH(S) = 0 THEN BEGIN
      {Empty line, finish previous line}
      IF LineLen > 0 THEN
        NewLine;
      {Insert blank line}
      NewLine;
      Exit;
    END;

    {Non-empty line}
    IF (S[1] = ' ') THEN
      {Finish previous line}
      IF LineLen > 0 THEN
        NewLine;

    Spos := 1;
    REPEAT

      {Write white space}
      WHILE (Spos <= LENGTH(S)) AND (S[Spos] = ' ') DO BEGIN
        IF LineLen < TextWid THEN BEGIN
          CharOut(S[Spos]);
          Inc(LineLen, LenCount(S[Spos]));
        END;
        Inc(Spos);
      END;
      IF Spos > LENGTH(S) THEN
        Exit;

      {See if next word fits on line}
      Tpos := Spos;
      Tlen := 0;
      REPEAT
        Inc(Tlen, LenCount(S[Tpos]));
        Inc(Tpos);
      UNTIL (Tpos > LENGTH(S)) OR (S[Tpos] = ' ');

      IF LineLen+Tlen > TextWid THEN
        {Word won't fit on line, start a new one}
        NewLine;

      {Write the word}
      WHILE Spos < Tpos DO BEGIN
        CharOut(S[Spos]);
        Inc(LineLen, LenCount(S[Spos]));
        Inc(Spos);
      END

    UNTIL Spos > LENGTH(S);

    {End line with blank}
    IF LineLen < TextWid THEN BEGIN
      CharOut(' ');
      Inc(LineLen);
    END;

  END;

  PROCEDURE ScanFile;
    {-Scan input file to create help text}
  VAR
    Ch : CHAR;
  BEGIN
    WITH Hdr DO BEGIN

      {Reread the input file}
      RESET(InF);
      SetTextBuf(InF, InBuff, FileBuffSize);

      {Correct default text dimensions for frames and spacing}
      TextWid := Width-4;

      {Initialize counters}
      LineNum := 0;
      CurSect := 0;
      LineLen := 0;
      SectLen := 0;
      OutPos := 0;

      WHILE NOT EOF(InF) DO BEGIN
        READLN(InF, S);
        UpdateLineNum;
        IF (LENGTH(S) = 0) OR (S[1] <> CommentMark) THEN BEGIN
          {Line is not a comment}
          IF (LENGTH(S) > 0) AND (S[1] = CommandMark) THEN BEGIN
            {A help metacommand}
            Spos := 2;
            ParseWord(S, Spos, C, 8);

            CASE ClassifyCommand(C) OF
              1 :            {TOPIC}
                BEGIN
                  IF CurSect <> 0 THEN
                    {Complete previous section}
                    NewSection;
                  {Get section number}
                  CurSect := ParseNumber(S, Spos, 'Topic number');
                  {Error check}
                  IF Hi^[CurSect] <> NoHelpAvailable THEN
                    ErrorLine('Duplicate help topic number');
                  {Store file index}
                  Hi^[CurSect] := SectPos;
                  {Get optional pick name}
                  SkipWhite(S, Spos);
                  C := COPY(S, Spos, 64);
                  IF LENGTH(C) > 0 THEN
                    {Store pick name}
                    StorePickName(C);
                END;

              2 :            {LINE}
                NewLine;

              3 :            {PAGE}
                NewPage;

              4 :            {WIDTH}
                IF CurSect <> 0 THEN
                  ErrorLine('WIDTH statement must precede first help topic')
                ELSE BEGIN
                  {Parse width}
                  Width := ParseNumber(S, Spos, 'Width');
                  {Correct dimension for frame and spacing}
                  TextWid := Width-4;
                END;

            ELSE
              ErrorLine('Unrecognized metacommand');
            END;

          END ELSE
            {A text line - wrap and output}
            LineOut;
        END;
      END;

      {Finalize status}
      WRITELN(^M, LineNum, ' total lines in help file');

      {Store last section}
      IF SectLen > 0 THEN
        NewSection;
      {Assure output goes to disk}
      FlushBuffer;

      {Write the updated header and indexes}
      RESET(OutF, 1);
      WriteHeaders;
      CLOSE(OutF);

    END;
  END;

BEGIN
  Initialize;
  CountFile;
  ScanFile;
END.