abspanst.pas

Lazarus is a free and open source development tool for the FreePascal Compiler. The purpose of the p

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower Abbrevia
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1997-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* ABBREVIA: AbSpanSt.pas 3.05                           *}
{*********************************************************}
{* ABBREVIA: TAbSpanStream Class                         *}
{*********************************************************}
{* Stream to handle spanning ZIP files to diskettes      *}
{*********************************************************}

{$I AbDefine.inc}

unit AbSpanSt;

interface

uses
  Classes,
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF}
  SysUtils, AbArcTyp, AbUtils, AbExcept;

type
  TAbSpanMode = (smReading, smWriting);
  TAbMediaType = (mtRemoveable, mtLocal);


  TAbSpanStream = class(TStream)
  private
    function GetSpace: LongInt;
    function FixSpanNumber(ImageNumber: Integer): Integer;
  protected {private}
    FSpanMode     : TAbSpanMode;  {Reading or Writing                }
    FMediaType    : TAbMediaType; {Local or Removeable               }
    FThreshold    : Longint;      {Max size that can be written      }
    FSpanNumber   : Integer;      {Contains sequence of curr. span   }
    FImageName    : string;       {Contains name of curr. image      }
    FCancelled    : Boolean;      {Determines whether to abort       }
    FBytesWritten : LongInt;      {Contains the no. of bytes
                                   written to the surrent span       }
    FBytesRead    : LongInt;

    FBytesAvail   : LongInt;      {Contains the no. of available
                                   bytes on the current media        }
    FStr          : TFileStream;  {Internal file stream              }
    FFileMode     : Word;         {File open mode for internal stream}
    FIgnoreSpanning : Boolean;      { only work within current span }    {!!.01}
    FSpanStreamInCharge : Boolean; {Span stream in charge of floppies} {!!.02}

    {fired when new media required   }
    FOnRequestImage     : TAbRequestImageEvent;
    FOnArchiveProgress  : TAbProgressEvent;                            {!!.04}
    FArchiveTotalWritten : Longint;                                    {!!.04}
    FArchiveTotalSize : Longint;                                       {!!.04}


    function MediaIsValid(FName : string) : Boolean;
    function DoRequestNewMedia{(const Prompt: string)}: Boolean;         {!!.01}
    function NextDefaultImageName : string;
    function ValidateImageName(NewName : string) : Boolean;
    procedure SetSize(NewSize: Longint); override;
  public
    constructor Create(const FileName: string; Mode: Word;
                       MediaType : TAbMediaType; Threshold : LongInt);
    destructor Destroy; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;

    procedure GotoNext;

    property SpanMode : TAbSpanMode read FSpanMode;
    property MediaType : TAbMediaType read FMediaType write FMediaType;
    property SpanNumber : Integer read FSpanNumber write FSpanNumber;   {!!.01}
    property Threshold : Longint
      read  FThreshold write FThreshold
      default 0;
    property OnRequestImage : TAbRequestImageEvent
      read FOnRequestImage write FOnRequestImage;
    property OnArchiveProgress  : TAbProgressEvent                     {!!.04}
      read FOnArchiveProgress write FOnArchiveProgress;                {!!.04}
    property ArchiveTotalSize : Longint                                {!!.04}
      read FArchiveTotalSize write FArchiveTotalSize;                  {!!.04}

    property FreeSpace : LongInt read
      GetSpace;

    property IgnoreSpanning : boolean                                    {!!.01}
      read FIgnoreSpanning write FIgnoreSpanning;                        {!!.01}
    property SpanStreamInCharge : Boolean                            {!!.02}
      read FSpanStreamInCharge write FSpanStreamInCharge;            {!!.02}

  end;

implementation

{!!.01 -- added}
function TAbSpanStream.FixSpanNumber(ImageNumber: Integer): Integer;
begin
  Result := ImageNumber;
  if MediaType = mtRemoveable then
    Result := Succ(ImageNumber);
end;
{!!.01 -- end added}


{------------------------------------------------------------------------------}
function TAbSpanStream.Read(var Buffer; Count: Longint): Longint;
var
  Valid : Boolean;
begin
  Result := 0;                                                           {!!.01}
  if FIgnoreSpanning then begin                                          {!!.01}
    Result := FStr.Read(Buffer, Count);                                  {!!.01}
  end                                                                    {!!.01}
  else begin
    if (Count > 0) and (FStr.Position = FStr.Size) then begin { need next span }
      if not Assigned(FOnRequestImage) then exit;
      FStr.Free;
      FStr := nil;
      Inc(FSpanNumber);
      FOnRequestImage(Self, FixSpanNumber(FSpanNumber),
        FImageName, FCancelled);                                         {!!.01}
      FSpanStreamInCharge := True;                                   {!!.02}
      Valid := MediaIsValid(FImageName);
      if Valid and not FCancelled then begin
        FStr := TFileStream.Create(FImageName, FFileMode);
      end else begin
        if not Valid then
          raise EAbFileNotFound.Create;
        if FCancelled then
          raise EAbUserAbort.Create;
      end;
    end else
      Result := 0;

    if Assigned(FStr) then
      Result := FStr.Read(Buffer, Count);
  end;                                                                   {!!.01}
end;
{------------------------------------------------------------------------------}
{!!.01 -- added}
function Least(const a : array of Integer) : Integer;
var
  i : Integer;
begin
  Result := a[0];
  for i := Low(a) + 1 to High(a) do
    if a[i] < Result then
      Result := a[i];
end;
{!!.01 -- end added}

{!!.01 -- re-written}
function TAbSpanStream.Write(const Buffer; Count: Longint): Longint;
var
  CurWritten, TotalWritten : LongInt;
  LocalBuff, LocalPtr : PAnsiChar;
  Abort : Boolean;                                                     {!!.04}
begin
  if FSpanMode = smReading then
    Result := 0
  else begin

    if FMediaType = mtLocal then begin                  { media not removeable }
      if (FThreshold = 0) then begin                    { not local span }
        TotalWritten := FStr.Write(Buffer, Count);      { write buffer }
      end

      else begin                                        { it's a local span }
        if GetSpace > Count then begin                  { there's room on }
                                                          { the local span }
          CurWritten := FStr.Write(Buffer, Count);      { write buffer }
          Inc(FBytesWritten, CurWritten);
          TotalWritten := CurWritten;
        end
        else begin                                      { not enough room }
          GetMem(LocalBuff, Count);
          Move(Buffer, LocalBuff^, Count);
          LocalPtr := LocalBuff;

          TotalWritten := FStr.Write(LocalPtr^, GetSpace); { write as much as }
                                                              { there's room for }
          Inc(LocalPtr, TotalWritten);

          while TotalWritten < Count do begin           { still data in Buffer }
            DoRequestNewMedia{('Media Full')};            { skip to next medium }

            CurWritten :=                               { write as much as }
              FStr.Write(LocalPtr^, Least([Count-TotalWritten, GetSpace])); { there's room for }
            Inc(LocalPtr, CurWritten);
            Inc(FBytesWritten, CurWritten);
            Inc(TotalWritten, CurWritten);
          end; {while}

          FreeMem(LocalBuff);
        end; {if FBytesAvail }
      end; {if GetSpace }

    end

    else begin { media IS removeable }
      if GetSpace > Count then begin                    { there's room on }
                                                          { removeable span }
        TotalWritten := FStr.Write(Buffer, Count);      { write buffer }
        Inc(FBytesWritten, TotalWritten);
      end
      else begin                                        { not enough room }
        GetMem(LocalBuff, Count);
        Move(Buffer, LocalBuff^, Count);
        LocalPtr := LocalBuff;

        TotalWritten := FStr.Write(LocalPtr^, GetSpace); { write as much as }
                                                          { there's room for }
        Inc(LocalPtr, TotalWritten);

        while TotalWritten < Count do begin           { still data in Buffer }
          DoRequestNewMedia{('Media Full')};            { skip to next medium }

          CurWritten :=                               { write as much as }
            FStr.Write(LocalPtr^, Least([Count-TotalWritten, GetSpace])); { there's room for }

            Inc(LocalPtr, CurWritten);
            Inc(FBytesWritten, CurWritten);
            Inc(TotalWritten, CurWritten);
          end; {while}
      end {if GetSpace}

    end; { if FMediaType }

{!!.04 - changed }
//    Result := TotalWritten
    Inc(FArchiveTotalWritten, TotalWritten);
    Abort := False;
    if Assigned(FOnArchiveProgress) then
      FOnArchiveProgress(AbPercentage(FArchiveTotalWritten, FArchiveTotalSize), Abort);
    if not Abort then
      Result := TotalWritten
    else
      Result := 0;
{!!.04 - changed end }

  end; {if FSpanMode }
end;
{!!.01 -- end re-written}

{------------------------------------------------------------------------------}
function TAbSpanStream.Seek(Offset: Longint; Origin: Word): Longint;
var
  Valid : Boolean;
  NewPos : LongInt;
begin
  { can only seek when reading }
  if FSpanMode = smWriting then
    Result := FStr.Position                                              {!!.01}
  else begin
    NewPos := FStr.Position;
    Result := NewPos;

    case Origin of
      soFromBeginning : NewPos := Offset;