1{
2    Copyright (c) 2013 by Yury Sidorov and the FPC Development Team
3
4    XML output of a PPU File
5
6    This program is free software; you can redistribute it and/or modify
7    it under the terms of the GNU General Public License as published by
8    the Free Software Foundation; either version 2 of the License, or
9    (at your option) any later version.
10
11    This program is distributed in the hope that it will be useful,
12    but WITHOUT ANY WARRANTY; without even the implied warranty of
13    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14    GNU General Public License for more details.
15
16    You should have received a copy of the GNU General Public License
17    along with this program; if not, write to the Free Software
18    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
19
20 ****************************************************************************}
21
22unit ppuxml;
23{$mode objfpc}{$H+}
24
25interface
26
27uses
28  SysUtils, Classes, ppuout;
29
30type
31  { TPpuXmlOutput }
32
33  TPpuXmlOutput = class(TPpuOutput)
34  private
35    function XmlStr(const s: string): string;
36    function GetTagName(const n, def: string): string;
37  protected
38    procedure WriteObjectStart(const AName: string; Def: TPpuDef); override;
39    procedure WriteObjectEnd(const AName: string; Def: TPpuDef); override;
40    procedure WriteArrayStart(const AName: string); override;
41    procedure WriteArrayEnd(const AName: string); override;
42    procedure WriteStr(const AName, AValue: string); override;
43  public
44    procedure Init; override;
45  end;
46
47implementation
48
49{ TPpuXmlOutput }
50
51function TPpuXmlOutput.XmlStr(const s: string): string;
52var
53  ws: widestring;
54  ps: PWideChar;
55  pd: PAnsiChar;
56  slen, dlen, dpos: integer;
57
58  procedure _AddChar(c: ansichar);
59  begin
60    if dpos = dlen then begin
61      dlen:=dlen*2;
62      SetLength(Result, dlen);
63      pd:=PAnsiChar(Result) + dpos;
64    end;
65    pd^:=c;
66    Inc(pd);
67    Inc(dpos);
68  end;
69
70  procedure _AddStr(const s: string);
71  var
72    p: PAnsiChar;
73    i: integer;
74  begin
75    p:=PAnsiChar(s);
76    for i:=1 to Length(s) do begin
77      _AddChar(p^);
78      Inc(p);
79    end;
80  end;
81
82var
83  c: widechar;
84begin
85  ws:=UTF8Decode(s);
86  ps:=PWideChar(ws);
87  slen:=Length(ws);
88  dlen:=slen + 2;
89  SetLength(Result, dlen);
90  pd:=PAnsiChar(Result);
91  dpos:=0;
92  while slen > 0 do begin
93    c:=ps^;
94    case c of
95      '<': _AddStr('&lt;');
96      '>': _AddStr('&gt;');
97      '&': _AddStr('&amp;');
98      '''': _AddStr('&apos;');
99      '"': _AddStr('&quot;');
100      '\': _AddStr('\\');
101      else
102        if (c > #127) or (byte(c) in [9, 10, 13]) then
103          _AddStr('&#x' + hexStr(word(c), 4) + ';')
104        else
105          if c < #32 then
106            _AddStr('\x' + hexStr(byte(c), 2))
107          else
108            _AddChar(c);
109    end;
110    Inc(ps);
111    Dec(slen);
112  end;
113  SetLength(Result, dpos);
114end;
115
116function TPpuXmlOutput.GetTagName(const n, def: string): string;
117begin
118  Result:=LowerCase(n);
119  if Result = '' then
120    Result:=def;
121end;
122
123procedure TPpuXmlOutput.WriteStr(const AName, AValue: string);
124begin
125  if AName = 'Type' then
126    exit;
127  WriteLn(Format('<%s>%s</%0:s>', [GetTagName(AName, 'value'), XmlStr(AValue)]));
128end;
129
130procedure TPpuXmlOutput.WriteArrayStart(const AName: string);
131begin
132  if (AName = '') and (Indent = 0) then
133    exit;
134  WriteLn(Format('<%s>', [GetTagName(AName, 'array')]));
135  inherited;
136end;
137
138procedure TPpuXmlOutput.WriteArrayEnd(const AName: string);
139begin
140  if (AName = '') and (Indent = 0) then
141    exit;
142  inherited;
143  WriteLn(Format('</%s>', [GetTagName(AName, 'array')]));
144end;
145
146procedure TPpuXmlOutput.WriteObjectStart(const AName: string; Def: TPpuDef);
147begin
148  if Def = nil then
149    WriteLn(Format('<%s>', [GetTagName(AName, 'object')]))
150  else
151    WriteLn(Format('<%s>', [GetTagName(Def.DefTypeName, 'object')]));
152  inherited;
153end;
154
155procedure TPpuXmlOutput.WriteObjectEnd(const AName: string; Def: TPpuDef);
156begin
157  inherited;
158  if Def = nil then
159    WriteLn(Format('</%s>', [GetTagName(AName, 'object')]))
160  else
161    WriteLn(Format('</%s>', [GetTagName(Def.DefTypeName, 'object')]));
162end;
163
164procedure TPpuXmlOutput.Init;
165begin
166  inherited Init;
167  WriteLn('<?xml version="1.0" encoding="utf-8"?>');
168end;
169
170end.
171
172