jvsurveyimpl.pas

jvcl driver development envionment

begin
  Result := FID;
end;

function TJvSurveyTaker.GetMailAddress: WideString;
begin
  Result := FMailAddress;
end;

function TJvSurveyTaker.GetNotes: WideString;
begin
  Result := FNotes;
end;

function TJvSurveyTaker.GetUserName: WideString;
begin
  Result := FUserName;
end;

procedure TJvSurveyTaker.SetID(const Value: WideString);
begin
  FID := Value;
end;

procedure TJvSurveyTaker.SetMailAddress(const Value: WideString);
begin
  FMailAddress := Value;
end;

procedure TJvSurveyTaker.SetNotes(const Value: WideString);
begin
  FNotes := Value;
end;

procedure TJvSurveyTaker.SetUserName(const Value: WideString);
begin
  FUserName := Value;
end;

{ TJvSurvey }

constructor TJvSurvey.Create;
begin
  inherited;
  FItems := TJvSurveyItems.Create;
  FSurveyTaker := TJvSurveyTaker.Create;
end;

destructor TJvSurvey.Destroy;
begin
  FItems := nil;
  FSurveyTaker := nil;
  inherited;
end;

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

function TJvSurvey.GetExpiryDate: TDateTime;
begin
  Result := FExpiryDate;
end;

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

function TJvSurvey.GetItems: IJvSurveyItems;
begin
  Result := FItems;
end;

function TJvSurvey.GetRecipient: WideString;
begin
  Result := FRecipient;
end;

function TJvSurvey.GetRecipientMail: WideString;
begin
  Result := FRecipientMail;
end;

function TJvSurvey.GetReleaseDate: TDateTime;
begin
  Result := FReleaseDate;
end;

function TJvSurvey.GetResultHREF: WideString;
begin
  Result := FResultHREF;
end;

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

procedure TJvSurvey.LoadFromFile(const Filename: WideString);
var
  F: TFileStream;
begin
  FFilename := Filename;
  F := TFileStream.Create(Filename, fmOpenRead);
  try
    LoadFromStream(F);
  finally
    F.Free;
  end;
end;

procedure TJvSurvey.ParseXML(Node: TJvSimpleXmlElem);
var
  i: integer;
  item: IJvSurveyItem;

begin
  if AnsiSameText(Node.Name, 'JEDISURVEY') then
  begin
    if Node.Properties.Value('Version', '') <> '1.0' then
      raise EJvSurveyError.CreateFmt(SErrUnsupportedVersionFmt, [Node.Properties.Value('Version', '')]);
  end
  else if AnsiSameText(Node.Name, 'SURVEY') then
  begin
    ID := Node.Properties.IntValue('ID', 0);
    Title := Node.Properties.Value('Title', '');
    ResultHREF := Node.Properties.Value('HREF', 'http://delphi-jedi.org');
    ReleaseDate := StrToDate(Node.Properties.Value('ReleaseDate', DateToStr(Date)));
    ExpiryDate := StrToDate(Node.Properties.Value('ExpiryDate', DateToStr(Date + 100)));
    Description := Node.Properties.Value('Description', '');
  end
  else if AnsiSameText(Node.Name, 'SURVEYTAKER') then
  begin
    SurveyTaker.ID := Node.Properties.Value('id', '');
    SurveyTaker.UserName := Node.Properties.Value('username', SurveyTaker.UserName);
    SurveyTaker.MailAddress := Node.Properties.Value('mailto', SurveyTaker.MailAddress);
    SurveyTaker.Notes := Node.Value;
  end
  else if AnsiSameText(Node.Name, 'RECIPIENT') then
  begin
    Recipient := Node.Properties.Value('username', '');
    RecipientMail := Node.Properties.Value('mailto', '');
    // TODO: recipient notes not used
  end
  else if AnsiSameText(Node.Name, 'ITEM') then
  begin
    item := Items.Add;
    item.ID := Node.Properties.IntValue('ID', Items.Count);
    item.Title := Node.Properties.Value('Title', '');
    item.Description := Node.Properties.Value('Description', '');
    item.SurveyType := DecodeType(Node.Properties.Value('Type', 'freeform'));
    item.Required := Node.Properties.BoolValue('Required', true);
    FLastItem := item;
  end
  else if AnsiSameText(Node.Name, 'CHOICES') then
  begin
    if FLastItem = nil then
      raise EJvSurveyError.CreateFmt(SErrInvalidFileFormatFmt, [Filename]);
    FLastItem.Choices := Node.Value;
  end
  else if AnsiSameText(Node.Name, 'RESPONSES') then
  begin
    if FLastItem = nil then
      raise EJvSurveyError.CreateFmt(SErrInvalidFileFormatFmt, [Filename]);
    FLastItem.Responses := Node.Value;
  end
  else if AnsiSameText(Node.Name, 'COMMENTS') then
  begin
    if FLastItem = nil then
      raise EJvSurveyError.CreateFmt(SErrInvalidFileFormatFmt, [Filename]);
    FLastItem.Comments := Node.Value;
  end;
  for i := 0 to Node.Items.Count - 1 do
    ParseXML(Node.Items[i]);
end;

function TJvSurvey.IsCompressedStream(Stream: TStream): boolean;
var
  buf: array[0..4] of char;
  Pos: Cardinal;
begin
  Pos := Stream.Read(buf[0], sizeof(buf));
  if Pos <> sizeof(buf) then
    raise Exception.Create('Invalid stream');
  Result := not AnsiSameText('<?xml', buf);
  Stream.Seek(-Pos, soFromCurrent);
end;

procedure CopyStream(Source,Dest:TStream);
var
  BufSize, N: Integer;
  Buffer: PChar;
begin
  BufSize := $F000;
  GetMem(Buffer, BufSize);
  try
    N := Source.Read(Buffer^,BufSize);
    while N = BufSize do
    begin
      Dest.Write(Buffer^,BufSize);
      N := Source.Read(Buffer^,BufSize);
    end;
    if N > 0 then
      Dest.Write(Buffer^,N);
  finally
    FreeMem(Buffer, BufSize);
  end;
end;

procedure TJvSurvey.DecompressStream(Source, Dest: TStream);
var
  ZStream: TDecompressionStream;
begin
  ZStream := TDecompressionStream.Create(Source);
  try
    CopyStream(ZStream,Dest); // decompress - doesn't work with Count = 0
  finally
    ZStream.Free;
  end;
end;

procedure TJvSurvey.CompressStream(Source, Dest: TStream);
var
  ZStream: TCompressionStream;
begin
  ZStream := TCompressionStream.Create(clMax, Dest);
  try
    ZStream.CopyFrom(Source, 0); // compress
  finally
    ZStream.Free;
  end;
  Dest.Seek(0, soFromBeginning);
end;

procedure TJvSurvey.LoadFromStream(Stream: TStream);
var
  X: TJvSimpleXML;
  AStream: TmemoryStream;
begin
  DecimalSeparator := '.';
  ShortDateFormat := 'YYYY-MM-DD';
  DateSeparator := '-';
  Items.Clear;
  AStream := TMemoryStream.Create;
  try
    if IsCompressedStream(Stream) then
    begin
      DecompressStream(Stream, AStream);
      AStream.Seek(0, soFromBeginning);
      Stream := AStream;
    end;
    X := TJvSimpleXML.Create(nil);
    try
      X.LoadFromStream(Stream);
      if not AnsiSameText(X.Root.Name, 'JEDISURVEY') then
        raise EJvSurveyError.CreateFmt(SErrUnknownFormatFmt, [Filename]);
      // set up defaults
      SurveyTaker.UserName := GetLocalUserName;
      SurveyTaker.MailAddress := Format('%s@%s.com', [GetLocalUserName, GetLocalComputerName]);
      ParseXML(X.Root);
    finally
      X.Free;
      GetFormatSettings;
    end;
    Items.Sort;
  finally
    AStream.Free;
  end;
end;

procedure TJvSurvey.SaveToFile(const Filename: WideString; Format: TJvSurveyFileFormat);
var
  F: TFileStream;
begin
  F := TFileStream.Create(Filename, fmCreate);
  try
    SaveToStream(F, Format);
    FFilename := Filename;
  finally
    F.Free;
  end;
end;

procedure TJvSurvey.SaveToStream(Stream: TStream; Format: TJvSurveyFileFormat);
var
  X: TJvSimpleXML;
  item, item2: TJvSimpleXmlElem;
  i: integer;
  PrologStream: TStringStream;
  AStream: TMemoryStream;
begin
  DecimalSeparator := '.';
  ShortDateFormat := 'YYYY-MM-DD';
  DateSeparator := '-';
  // DONE: build XML doc
  X := TJvSimpleXML.Create(nil);
  try
    Items.Sort;
    // this is weird: does it really have to be this complicated?
    PrologStream := TStringStream.Create('<?xml version="1.0" stand-alone="yes" encoding="UTF-8" ?>');
    try
      PrologStream.Seek(0, soFromBeginning);
      X.Prolog.LoadFromStream(PrologStream);
    finally
      PrologStream.Free;
    end;
    X.Root.Name := 'JEDISURVEY';
    X.Root.Properties.Add('Version', '1.0');
    item := X.Root.Items.Add('SURVEY');
    item.Properties.Add('ID', ID);
    item.Properties.Add('Title', Title);
    item.Properties.Add('ReleaseDate', DateToStr(ReleaseDate));
    item.Properties.Add('ExpiryDate', DateToStr(ExpiryDate));
    item.Properties.Add('HREF', ResultHREF);
    item.Properties.Add('Description', Description);
    item := X.Root.Items.Add('RECIPIENT');
    item.Properties.Add('username', Recipient);
    item.Properties.Add('mailto', RecipientMail);
    item := X.Root.Items.Add('SURVEYTAKER');
    item.Properties.Add('username', SurveyTaker.UserName);
    item.Properties.Add('mailto', SurveyTaker.MailAddress);
    item.Properties.Add('id', SurveyTaker.ID);

    item := X.Root.Items.Add('ITEMS');
    for i := 0 to self.Items.Count - 1 do
    begin
      item2 := item.Items.Add('ITEM');
      item2.Properties.Add('ID', self.Items[i].ID);
      item2.Properties.Add('Title', self.Items[i].Title);
      item2.Properties.Add('Type', EncodeType(self.Items[i].SurveyType));
      item2.Properties.Add('Required', self.Items[i].Required);
      item2.Properties.Add('Description', self.Items[i].Description);
      with item2.Items.Add('CHOICES') do
        Value := EncodeChoice(self.Items[i].Choices, self.Items[i].SurveyType);
      with item2.Items.Add('RESPONSES') do
        Value := EncodeResponse(self.Items[i].Responses, self.Items[i].SurveyType);
      with item2.Items.Add('COMMENTS') do
        Value := EncodeResponse(self.Items[i].Comments,stFreeForm);
    end;
    X.SaveToStream(Stream);
    if Format = ffBinary then
    begin
      AStream := TMemoryStream.Create;
      try
        CompressStream(Stream, AStream);
        Stream.Size := 0;
        Stream.CopyFrom(AStream, 0);
      finally
        AStream.Free;
      end;
    end;
  finally
    X.Free;
    GetFormatSettings;
  end;
end;

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

procedure TJvSurvey.SetExpiryDate(const Value: TDateTime);
begin
  FExpiryDate := Value;
end;

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

procedure TJvSurvey.SetRecipient(const Value: WideString);
begin
  FRecipient := Value;
end;

procedure TJvSurvey.SetRecipientMail(const Value: WideString);
begin
  FRecipientMail := Value;
end;

procedure TJvSurvey.SetReleaseDate(const Value: TDateTime);
begin
  FReleaseDate := Value;
end;

procedure TJvSurvey.SetResultHREF(const Value: WideString);
begin
  FResultHREF := Value;
end;

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

function TJvSurvey.GetSurveyTaker: IJvSurveyTaker;
begin
  Result := FSurveyTaker;
end;

initialization
  CreateSurvey := @InternalCreateSurvey;

end.