← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/packages/extra/gtk/conv/fixgtk.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/extra/gtk/conv/fixgtk.pp
 
1
    function lower(const s : string) : string;
 
2
    {
 
3
      return lowercased string of s
 
4
    }
 
5
      var
 
6
         i : longint;
 
7
      begin
 
8
         for i:=1 to length(s) do
 
9
          if s[i] in ['A'..'Z'] then
 
10
           lower[i]:=char(byte(s[i])+32)
 
11
          else
 
12
           lower[i]:=s[i];
 
13
         lower[0]:=s[0];
 
14
      end;
 
15
 
 
16
    function upper(const s : string) : string;
 
17
    {
 
18
      return lowercased string of s
 
19
    }
 
20
      var
 
21
         i : longint;
 
22
      begin
 
23
         for i:=1 to length(s) do
 
24
          if s[i] in ['a'..'z'] then
 
25
           upper[i]:=char(byte(s[i])-32)
 
26
          else
 
27
           upper[i]:=s[i];
 
28
         upper[0]:=s[0];
 
29
      end;
 
30
 
 
31
   function trimspace(const s:string):string;
 
32
     var
 
33
       i,j : longint;
 
34
     begin
 
35
       i:=length(s);
 
36
       while (i>0) and (s[i] in [#9,' ']) do
 
37
        dec(i);
 
38
       j:=1;
 
39
       while (j<i) and (s[j] in [#9,' ']) do
 
40
        inc(j);
 
41
       trimspace:=Copy(s,j,i-j+1);
 
42
     end;
 
43
 
 
44
   function trimbegin(const s:string):string;
 
45
     var
 
46
       i,j : longint;
 
47
     begin
 
48
       i:=length(s);
 
49
       j:=1;
 
50
       while (j<i) and (s[j] in [#9,' ']) do
 
51
        inc(j);
 
52
       trimbegin:=Copy(s,j,i-j+1);
 
53
     end;
 
54
 
 
55
    procedure Replace(var s:string;const s1,s2:string;single:boolean);
 
56
      var
 
57
         last,
 
58
         i  : longint;
 
59
      begin
 
60
        last:=0;
 
61
        repeat
 
62
          i:=pos(s1,upper(s));
 
63
          if i=last then
 
64
           i:=0;
 
65
          if (i>0) then
 
66
           begin
 
67
             Delete(s,i,length(s1));
 
68
             Insert(s2,s,i);
 
69
             last:=i;
 
70
           end;
 
71
        until single or (i=0);
 
72
      end;
 
73
 
 
74
    procedure ReplaceCase(var s:string;const s1,s2:string;single:boolean);
 
75
      var
 
76
         last,
 
77
         i  : longint;
 
78
      begin
 
79
        last:=0;
 
80
        repeat
 
81
          i:=pos(s1,s);
 
82
          if i=last then
 
83
           i:=0;
 
84
          if (i>0) then
 
85
           begin
 
86
             Delete(s,i,length(s1));
 
87
             Insert(s2,s,i);
 
88
             last:=i;
 
89
           end;
 
90
        until single or (i=0);
 
91
      end;
 
92
 
 
93
    procedure fixreplace(var s:string);
 
94
      begin
 
95
        replace(s,'P_GTK','PGtk',false);
 
96
        replace(s,'= ^T_GTK','= ^TGtk',false);
 
97
        replace(s,'^T_GTK','PGtk',false);
 
98
        replace(s,'T_GTK','TGtk',false);
 
99
        replace(s,'^GTK','PGtk',false);
 
100
        replace(s,'EXTERNAL_LIBRARY','gtkdll',false);
 
101
        replacecase(s,' Gtk',' TGtk',false);
 
102
        replacecase(s,':Gtk',':TGtk',false);
 
103
        replace(s,'^G','PG',false);
 
104
      end;
 
105
 
 
106
 
 
107
var
 
108
  t,f : text;
 
109
  ssmall : string[20];
 
110
  hs,
 
111
  s   : string;
 
112
  name : string;
 
113
  i    : word;
 
114
  func,
 
115
  impl : boolean;
 
116
begin
 
117
  impl:=false;
 
118
  assign(t,paramstr(1));
 
119
  assign(f,'fixgtk.tmp');
 
120
  reset(t);
 
121
  rewrite(f);
 
122
  writeln(f,'{');
 
123
  writeln(f,'}');
 
124
  writeln(f,'');
 
125
  writeln(f,'{$ifndef gtk_include_files}');
 
126
  writeln(f,'  {$define read_interface}');
 
127
  writeln(f,'  {$define read_implementation}');
 
128
  writeln(f,'{$endif not gtk_include_files}');
 
129
  writeln(f,'');
 
130
  writeln(f,'{$ifndef gtk_include_files}');
 
131
  writeln(f,'');
 
132
  writeln(f,'  unit ',Copy(paramstr(1),1,pos('.',paramstr(1))-1),';');
 
133
  writeln(f,'  interface');
 
134
  writeln(f,'');
 
135
  writeln(f,'  uses');
 
136
  writeln(f,'    glib,gdkmain,');
 
137
  writeln(f,'    gtkobjects;');
 
138
  writeln(f,'');
 
139
  writeln(f,'  {$ifdef win32}');
 
140
  writeln(f,'    const');
 
141
  writeln(f,'      gtkdll=''gtk-1.1.dll''; { leave the .dll else .1.1 -> .1 !! }');
 
142
  writeln(f,'  {$else}');
 
143
  writeln(f,'    const');
 
144
  writeln(f,'      gtkdll=''gtk.so'';');
 
145
  writeln(f,'    {$linklib c}');
 
146
  writeln(f,'  {$endif}');
 
147
  writeln(f,'');
 
148
  writeln(f,'  Type');
 
149
  writeln(f,'    PLongint  = ^Longint;');
 
150
  writeln(f,'    PByte     = ^Byte;');
 
151
  writeln(f,'    PWord     = ^Word;');
 
152
  writeln(f,'    PINteger  = ^Integer;');
 
153
  writeln(f,'    PCardinal = ^Cardinal;');
 
154
  writeln(f,'    PReal     = ^Real;');
 
155
  writeln(f,'    PDouble   = ^Double;');
 
156
  writeln(f,'');
 
157
  writeln(f,'{$endif not gtk_include_files}');
 
158
  writeln(f,'');
 
159
  writeln(f,'{$ifdef read_interface}');
 
160
  writeln(f,'');
 
161
  while not eof(t) do
 
162
   begin
 
163
     read(t,ssmall);
 
164
     fixreplace(ssmall);
 
165
 
 
166
     if (not impl) and (copy(trimspace(ssmall),1,14)='implementation') then
 
167
      begin
 
168
        impl:=true;
 
169
        readln(t,s);
 
170
        writeln(f,'{$endif read_interface}');
 
171
        writeln(f,'');
 
172
        writeln(f,'');
 
173
        writeln(f,'{$ifndef gtk_include_files}');
 
174
        writeln(f,'  implementation');
 
175
        writeln(f,'{$endif not gtk_include_files}');
 
176
        writeln(f,'');
 
177
        writeln(f,'{$ifdef read_implementation}');
 
178
        writeln(f,'');
 
179
        continue;
 
180
      end;
 
181
     if (impl) and (copy(trimspace(ssmall),1,4)='end.') then
 
182
      begin
 
183
        writeln(f,'{$endif read_implementation}');
 
184
        writeln(f,'');
 
185
        writeln(f,'');
 
186
        writeln(f,'{$ifndef gtk_include_files}');
 
187
        writeln(f,'end.');
 
188
        writeln(f,'{$endif not gtk_include_files}');
 
189
        writeln(f,'');
 
190
        writeln(f,'{');
 
191
 
 
192
  Revision 1.3  2005/02/14 17:13:20  peter
 
193
    * truncate log
 
194
 
 
195
}