Power-Programmierung/CD1.mdf/pascal/library/dos/t_power/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.