jvsurveyimpl.pas

jvcl driver development envionment

{******************************************************************

                       JEDI-VCL Demo

 Copyright (C) 2002 Project JEDI

 Original author:

 You may retrieve the latest version of this file at the JEDI-JVCL
 home page, located at http://jvcl.sourceforge.net

 The contents of this file are used with permission, 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/MPL-1_1Final.html

 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.

******************************************************************}

unit JvSurveyImpl;

interface

uses
  SysUtils, Classes,
  JvSurveyIntf, JvSimpleXML;

type
  EJvSurveyError = class(Exception);

  TJvSurveyItem = class(TInterfacedObject, IUnknown, IJvSurveyItem)
  private
    FChoices: WideString;
    FResponses: WideString;
    FDescription: WideString;
    FComments:WideString;
    FID: integer;
    FRequired: WordBool;
    FSurveyType: TJvSurveyType;
    FTitle: WideString;
    function GetChoices: WideString;
    function GetDescription: WideString;
    function GetID: Integer;
    function GetRequired: WordBool;
    function GetResponses: WideString;
    function GetSurveyType: TJvSurveyType;
    function GetTitle: WideString;
    procedure SetDescription(const Value: WideString);
    procedure SetID(const Value: Integer);
    procedure SetRequired(const Value: WordBool);
    procedure SetSurveyType(const Value: TJvSurveyType);
    procedure SetTitle(const Value: WideString);
    procedure SetChoices(const Value: WideString);
    procedure SetResponses(const Value: WideString);
    function GetComments: WideString;
    procedure SetComments(const Value: WideString);
  public
    constructor Create;
    destructor Destroy; override;

    procedure SortResponses;

    property ID: integer read GetID write SetID;
    property Title: WideString read GetTitle write SetTitle;
    property Description: WideString read GetDescription write SetDescription;
    property SurveyType: TJvSurveyType read GetSurveyType write SetSurveyType;
    property Choices: WideString read GetChoices write SetChoices;
    property Responses: WideString read GetResponses write SetResponses;
    property Required: WordBool read GetRequired write SetRequired;
    property Comments:WideString read GetComments write SetComments;

  end;

  TJvSurveyItems = class(TInterfacedObject, IUnknown, IJvSurveyItems)
  private
    FItems: TInterfaceList;
    function Add: IJvSurveyItem;
    procedure Delete(Index: Integer);
    procedure Clear;
    procedure Sort;
    function GetCount: Integer;
    function GetItem(Index: Integer): IJvSurveyItem;
  public
    constructor Create;
    destructor Destroy; override;

    property Items[Index: integer]: IJvSurveyItem read GetItem;
    property Count: integer read GetCount;
  end;

  TJvSurveyTaker = class(TInterfacedObject, IUnknown, IJvSurveyTaker)
  private
    FUserName: WideString;
    FMailAddress: WideString;
    FNotes: WideString;
    FID: WideString;
    function GetUserName: WideString;
    procedure SetUserName(const Value: WideString);
    function GetMailAddress: WideString;
    function GetNotes: WideString;
    procedure SetMailAddress(const Value: WideString);
    procedure SetNotes(const Value: WideString);
    function GetID: WideString;
    procedure SetID(const Value: WideString);
  public
    property ID: WideString read GetID write SetID;
    property UserName: WideString read GetUserName write SetUserName;
    property MailAddress: WideString read GetMailAddress write SetMailAddress;
    property Notes: WideString read GetNotes write SetNotes;
  end;

  TJvSurvey = class(TInterfacedObject, IUnknown, IJvSurvey)
  private
    FDescription: WideString;
    FID: integer;
    FItems: IJvSurveyItems;
    FRecipient: WideString;
    FTitle: WideString;
    FRecipientMail: WideString;
    FReleaseDate: TDateTime;
    FExpiryDate: TDateTime;
    FResultHREF: WideString;
    FSurveyTaker: IJvSurveyTaker;
    FFilename: string;
    FLastItem: IJvSurveyItem;
    function GetDescription: WideString;
    function GetID: Integer;
    function GetItems: IJvSurveyItems;
    function GetRecipient: WideString;
    function GetTitle: WideString;
    procedure SetDescription(const Value: WideString);
    procedure SetID(const Value: Integer);
    procedure SetRecipient(const Value: WideString);
    procedure SetTitle(const Value: WideString);
    function GetRecipientMail: WideString;
    procedure SetRecipientMail(const Value: WideString);
    function GetReleaseDate: TDateTime;
    procedure SetReleaseDate(const Value: TDateTime);
    function GetExpiryDate: TDateTime;
    procedure SetExpiryDate(const Value: TDateTime);
    function GetResultHREF: WideString;
    procedure SetResultHREF(const Value: WideString);
    function GetSurveyTaker: IJvSurveyTaker;
    procedure ParseXML(Node: TJvSimpleXmlElem);
    function IsCompressedStream(Stream: TStream): boolean;
    procedure DecompressStream(Source, Dest: TStream);
    procedure CompressStream(Source, Dest: TStream);
  public
    constructor Create;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream; Format: TJvSurveyFileFormat);
    procedure LoadFromFile(const Filename: WideString);
    procedure SaveToFile(const Filename: WideString; Format: TJvSurveyFileFormat);
    property ID: integer read GetID write SetID;
    property Title: WideString read GetTitle write SetTitle;
    property Description: WideString read GetDescription write SetDescription;
    property Items: IJvSurveyItems read GetItems;
    property Recipient: WideString read GetRecipient write SetRecipient;
    property RecipientMail: WideString read GetRecipientMail write SetRecipientMail;
    property ResultHRef: WideString read GetResultHREF write SetResultHREF;
    property ReleaseDate: TDateTime read GetReleaseDate write SetReleaseDate;
    property ExpiryDate: TDateTime read GetExpiryDate write SetExpiryDate;
    property SurveyTaker: IJvSurveyTaker read GetSurveyTaker;

    property Filename: string read FFilename;
  end;

implementation

uses
  ZLib,
  JclSysInfo, JvJVCLUtils, JvSurveyUtils;

resourcestring
  SErrUnknownFormatFmt = 'Unknown survey format in "%s"!';
  SErrUnsupportedVersionFmt = 'Unsupported version (%s)';
  SErrInvalidFileFormatFmt = 'Invalid survey file "%s"';

function InternalCreateSurvey: IJvSurvey;
begin
  Result := TJvSurvey.Create;
end;

{ TJvSurveyItem }

constructor TJvSurveyItem.Create;
begin
  inherited Create;
end;

destructor TJvSurveyItem.Destroy;
begin
  inherited;
end;

function TJvSurveyItem.GetChoices: WideString;
begin
  Result := FChoices;
end;

function TJvSurveyItem.GetDescription: WideString;
begin
  Result := FDescription;
end;

function TJvSurveyItem.GetID: Integer;
begin
  Result := FID;
end;

function TJvSurveyItem.GetRequired: WordBool;
begin
  Result := FRequired;
end;

function TJvSurveyItem.GetResponses: WideString;
begin
  Result := FResponses;
end;

function TJvSurveyItem.GetSurveyType: TJvSurveyType;
begin
  Result := FSurveyType;
end;

function TJvSurveyItem.GetTitle: WideString;
begin
  Result := FTitle;
end;

procedure TJvSurveyItem.SetChoices(const Value: WideString);
begin
  FChoices := Value;
end;

procedure TJvSurveyItem.SetDescription(const Value: WideString);
begin
  FDescription := Value;
end;

procedure TJvSurveyItem.SetID(const Value: Integer);
begin
  FID := Value;
end;

procedure TJvSurveyItem.SetResponses(const Value: WideString);
begin
  Fresponses := Value;
end;

procedure TJvSurveyItem.SetRequired(const Value: WordBool);
begin
  FRequired := Value;
end;

procedure TJvSurveyItem.SetSurveyType(const Value: TJvSurveyType);
begin
  FSurveyType := Value;
end;

procedure TJvSurveyItem.SetTitle(const Value: WideString);
begin
  FTitle := Value;
end;

function InvertResponseSort(List: TStringList; Index1, Index2: Integer): Integer;
begin
  Result := StrToIntDef(List[Index2], 0) - StrToIntDef(List[Index1], 0);
end;

procedure TJvSurveyItem.SortResponses;
var
  C, C2, R: TStringlist;
  i, j: integer;
begin
  if SurveyType = stFreeForm then Exit;
  // sort on responses, i.e change '0,0,1,2,0,4' into '4,2,1,0,0,0', choices are sorted accordingly
  // (p3) there must be a simpler way of doing this...
  C := TStringlist.Create;
  C2 := TStringlist.Create;
  R := TStringlist.Create;
  try
    C.Text := DecodeChoice(Choices, SurveyType);
    C2.Text := C.Text;
    R.Text := DecodeResponse(Responses, SurveyType);
    while R.Count < C.Count do
      R.Add('0');
    while C.Count < R.Count do
      R.Delete(R.Count - 1);
    for i := 0 to R.Count - 1 do
      R.Objects[i] := TObject(i); // save old index
    R.CustomSort(InvertResponseSort);
    for i := 0 to R.Count - 1 do
    begin
      j := integer(R.Objects[i]);
      C2[i] := C[j]; // move items according to index
    end;
    Choices := EncodeChoice(C2.Text, Surveytype);
    Responses := EncodeResponse(R.Text, Surveytype);
  finally
    C.Free;
    C2.Free;
    R.Free;
  end;
end;

function TJvSurveyItem.GetComments: WideString;
begin
  Result := FComments;
end;

procedure TJvSurveyItem.SetComments(const Value: WideString);
begin
  FComments := Value;
end;

{ TJvSurveyItems }

function TJvSurveyItems.Add: IJvSurveyItem;
begin
  Result := TJvSurveyItem.Create;
  Result.ID := -1;
  FItems.Add(Result);
end;

procedure TJvSurveyItems.Clear;
begin
  FItems.Count := 0;
end;

constructor TJvSurveyItems.Create;
begin
  inherited Create;
  FItems := TInterfacelist.Create;
end;

procedure TJvSurveyItems.Delete(Index: Integer);
begin
  FItems.Delete(Index);
end;

destructor TJvSurveyItems.Destroy;
begin
  FItems := nil;
  inherited;
end;

function TJvSurveyItems.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TJvSurveyItems.GetItem(Index: Integer): IJvSurveyItem;
begin
  Result := FItems[Index] as IJvSurveyItem;
end;

type
  TInterfaceListSortCompare = function(const Item1, Item2: IUnknown): integer;

procedure QuickSort(AList: TInterfaceList; L, R: Integer;
  SCompare: TInterfaceListSortCompare);
var
  I, J: Integer;
  P, T: IUnknown;
begin
  repeat
    I := L;
    J := R;
    P := AList[(L + R) shr 1];
    repeat
      while SCompare(AList[I], P) < 0 do
        Inc(I);
      while SCompare(AList[J], P) > 0 do
        Dec(J);
      if I <= J then
      begin
        T := AList[I];
        AList[I] := AList[J];
        AList[J] := T;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then
      QuickSort(AList, L, J, SCompare);
    L := I;
  until I >= R;
end;

function IDCompare(const Item1, Item2: IUnknown): integer;
begin
  Result := (Item1 as IJvSurveyItem).ID - (Item2 as IJvSurveyItem).ID;
end;

procedure TJvSurveyItems.Sort;
begin
  if Count > 1 then
    QuickSort(FItems, 0, Count - 1, IDCompare);
end;

{ TJvSurveyTaker }

function TJvSurveyTaker.GetID: WideString;