mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-07 12:07:58 +02:00
* Initial check-in of pas2js changes
git-svn-id: trunk@37749 -
This commit is contained in:
michael
parent
5fd1d28f62
commit
8342c502c5
11
.gitattributes
vendored
11
.gitattributes
vendored
@ -16936,9 +16936,20 @@ utils/pas2jni/writer.pas svneol=native#text/plain
|
||||
utils/pas2js/Makefile svneol=native#text/plain
|
||||
utils/pas2js/Makefile.fpc svneol=native#text/plain
|
||||
utils/pas2js/dist/rtl.js svneol=native#text/plain
|
||||
utils/pas2js/docs/translation.html svneol=native#text/html
|
||||
utils/pas2js/fpmake.lpi svneol=native#text/plain
|
||||
utils/pas2js/fpmake.pp svneol=native#text/plain
|
||||
utils/pas2js/pas2js.cfg svneol=native#text/plain
|
||||
utils/pas2js/pas2js.lpi svneol=native#text/plain
|
||||
utils/pas2js/pas2js.pp svneol=native#text/plain
|
||||
utils/pas2js/pas2js_defines.inc svneol=native#text/plain
|
||||
utils/pas2js/pas2jscompiler.pp svneol=native#text/plain
|
||||
utils/pas2js/pas2jsfilecache.pp svneol=native#text/plain
|
||||
utils/pas2js/pas2jsfileutils.pp svneol=native#text/plain
|
||||
utils/pas2js/pas2jsfileutilsunix.inc svneol=native#text/plain
|
||||
utils/pas2js/pas2jsfileutilswin.inc svneol=native#text/plain
|
||||
utils/pas2js/pas2jslogger.pp svneol=native#text/plain
|
||||
utils/pas2js/pas2jspparser.pp svneol=native#text/plain
|
||||
utils/pas2js/samples/arraydemo.pp svneol=native#text/plain
|
||||
utils/pas2js/samples/fordemo.pp svneol=native#text/plain
|
||||
utils/pas2js/samples/fordowndemo.pp svneol=native#text/plain
|
||||
|
||||
739
utils/pas2js/dist/rtl.js
vendored
739
utils/pas2js/dist/rtl.js
vendored
@ -1,30 +1,10 @@
|
||||
/*
|
||||
This file is part of the Free Pascal pas2js tool.
|
||||
Copyright (c) 2017 Mattias Gaertner
|
||||
|
||||
Basic RTL for pas2js programs.
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
*/
|
||||
|
||||
var pas = {};
|
||||
var pas = {};
|
||||
|
||||
var rtl = {
|
||||
|
||||
quiet: false,
|
||||
debug_load_units: false,
|
||||
|
||||
m_loading: 0,
|
||||
m_loading_intf: 1,
|
||||
m_intf_loaded: 2,
|
||||
m_loading_impl: 3, // loading all used unit
|
||||
m_initializing: 4, // running initialization
|
||||
m_initialized: 5,
|
||||
debug_rtti: false,
|
||||
|
||||
debug: function(){
|
||||
if (rtl.quiet || !console || !console.log) return;
|
||||
@ -40,97 +20,130 @@ var rtl = {
|
||||
rtl.debug('Warn: ',s);
|
||||
},
|
||||
|
||||
isArray: function(a) {
|
||||
return a instanceof Array;
|
||||
},
|
||||
|
||||
isNumber: function(n){
|
||||
return typeof(n)=="number";
|
||||
},
|
||||
|
||||
isInteger: function(A){
|
||||
return Math.floor(A)===A;
|
||||
},
|
||||
|
||||
isBoolean: function(b){
|
||||
return typeof(b)=="boolean";
|
||||
},
|
||||
|
||||
isString: function(s){
|
||||
return typeof(s)=="string";
|
||||
},
|
||||
|
||||
isObject: function(o){
|
||||
return typeof(o)=="object";
|
||||
},
|
||||
|
||||
isFunction: function(f){
|
||||
return typeof(f)=="function";
|
||||
},
|
||||
|
||||
isNull: function(o){
|
||||
return (o==null && typeof(o)=='object') || o==undefined;
|
||||
},
|
||||
|
||||
isRecord: function(r){
|
||||
return (typeof(r)=="function") && (typeof(r.$create) == "function");
|
||||
},
|
||||
|
||||
isClass: function(c){
|
||||
return (typeof(o)=="object") && (o.$class == o);
|
||||
},
|
||||
|
||||
isClassInstance: function(c){
|
||||
return (typeof(o)=="object") && (o.$class == Object.getPrototypeOf(o));
|
||||
},
|
||||
|
||||
hasString: function(s){
|
||||
return rtl.isString(s) && (s.length>0);
|
||||
},
|
||||
|
||||
module: function(module_name, intfuseslist, code, impluseslist){
|
||||
if (rtl.debug_load_units) rtl.debug('rtl.module name="'+module_name+'" intfuses='+intfuseslist+' impluses='+impluseslist);
|
||||
isArray: function(a) {
|
||||
return Array.isArray(a);
|
||||
},
|
||||
|
||||
isFunction: function(f){
|
||||
return typeof(f)==="function";
|
||||
},
|
||||
|
||||
isModule: function(m){
|
||||
return rtl.isObject(m) && rtl.hasString(m.$name) && (pas[m.$name]===m);
|
||||
},
|
||||
|
||||
isImplementation: function(m){
|
||||
return rtl.isObject(m) && rtl.isModule(m.$module) && (m.$module.$impl===m);
|
||||
},
|
||||
|
||||
isNumber: function(n){
|
||||
return typeof(n)==="number";
|
||||
},
|
||||
|
||||
isObject: function(o){
|
||||
var s=typeof(o);
|
||||
return (typeof(o)==="object") && (o!=null);
|
||||
},
|
||||
|
||||
isString: function(s){
|
||||
return typeof(s)==="string";
|
||||
},
|
||||
|
||||
getNumber: function(n){
|
||||
return typeof(n)==="number"?n:NaN;
|
||||
},
|
||||
|
||||
getChar: function(c){
|
||||
return ((typeof(c)==="string") && (c.length===1)) ? c : "";
|
||||
},
|
||||
|
||||
getObject: function(o){
|
||||
return ((typeof(o)==="object") || (typeof(o)==='function')) ? o : null;
|
||||
},
|
||||
|
||||
m_loading: 0,
|
||||
m_loading_intf: 1,
|
||||
m_intf_loaded: 2,
|
||||
m_loading_impl: 3, // loading all used unit
|
||||
m_initializing: 4, // running initialization
|
||||
m_initialized: 5,
|
||||
|
||||
module: function(module_name, intfuseslist, intfcode, impluseslist, implcode){
|
||||
if (rtl.debug_load_units) rtl.debug('rtl.module name="'+module_name+'" intfuses='+intfuseslist+' impluses='+impluseslist+' hasimplcode='+rtl.isFunction(implcode));
|
||||
if (!rtl.hasString(module_name)) rtl.error('invalid module name "'+module_name+'"');
|
||||
if (!rtl.isArray(intfuseslist)) rtl.error('invalid interface useslist of "'+module_name+'"');
|
||||
if (!rtl.isFunction(code)) rtl.error('invalid module code of "'+module_name+'"');
|
||||
if ((impluseslist!=undefined) && !rtl.isArray(impluseslist)) rtl.error('invalid implementation useslist of "'+module_name+'"');
|
||||
if (!rtl.isFunction(intfcode)) rtl.error('invalid interface code of "'+module_name+'"');
|
||||
if (!(impluseslist==undefined) && !rtl.isArray(impluseslist)) rtl.error('invalid implementation useslist of "'+module_name+'"');
|
||||
if (!(implcode==undefined) && !rtl.isFunction(implcode)) rtl.error('invalid implementation code of "'+module_name+'"');
|
||||
|
||||
if (pas[module_name])
|
||||
rtl.error('module "'+module_name+'" already registered');
|
||||
rtl.error('module "'+module_name+'" is already registered');
|
||||
|
||||
var module = pas[module_name] = {
|
||||
$name: module_name,
|
||||
$intfuseslist: intfuseslist,
|
||||
$impluseslist: impluseslist,
|
||||
$state: rtl.m_loading,
|
||||
$code: code
|
||||
$intfcode: intfcode,
|
||||
$implcode: implcode,
|
||||
$impl: null,
|
||||
$rtti: Object.create(rtl.tSectionRTTI),
|
||||
};
|
||||
module.$rtti.$module = module;
|
||||
if (implcode) module.$impl = {
|
||||
$module: module,
|
||||
$rtti: module.$rtti,
|
||||
};
|
||||
},
|
||||
|
||||
exitcode: 0,
|
||||
|
||||
run: function(module_name){
|
||||
if (module_name==undefined) module_name='program';
|
||||
if (rtl.debug_load_units) rtl.debug('rtl.run module="'+module_name+'"');
|
||||
var module = pas[module_name];
|
||||
rtl.loadintf(module);
|
||||
rtl.loadimpl(module);
|
||||
if (module_name=='program'){
|
||||
if (rtl.debug_load_units) rtl.debug('running $main');
|
||||
pas.program.$main();
|
||||
function doRun(){
|
||||
if (!rtl.hasString(module_name)) module_name='program';
|
||||
if (rtl.debug_load_units) rtl.debug('rtl.run module="'+module_name+'"');
|
||||
rtl.initRTTI();
|
||||
var module = pas[module_name];
|
||||
if (!module) rtl.error('rtl.run module "'+module_name+'" missing');
|
||||
rtl.loadintf(module);
|
||||
rtl.loadimpl(module);
|
||||
if (module_name=='program'){
|
||||
if (rtl.debug_load_units) rtl.debug('running $main');
|
||||
var r = pas.program.$main();
|
||||
if (rtl.isNumber(r)) rtl.exitcode = r;
|
||||
}
|
||||
}
|
||||
return pas.System.ExitCode;
|
||||
|
||||
if (rtl.showUncaughtExceptions) {
|
||||
try{
|
||||
doRun();
|
||||
} catch(re) {
|
||||
var errMsg = re.hasOwnProperty('$class') ? re.$class.$classname : '';
|
||||
errMsg += ((errMsg) ? ': ' : '') + (re.hasOwnProperty('fMessage') ? re.fMessage : re);
|
||||
alert('Uncaught Exception : '+errMsg);
|
||||
rtl.exitCode = 216;
|
||||
}
|
||||
} else {
|
||||
doRun();
|
||||
}
|
||||
return rtl.exitcode;
|
||||
},
|
||||
|
||||
loadintf: function(module){
|
||||
if (module.state>rtl.m_loading_intf) return; // already finished
|
||||
if (rtl.debug_load_units) rtl.debug('loadintf: '+module.$name);
|
||||
if (module.$state==rtl.m_loading_intf)
|
||||
if (module.$state>rtl.m_loading_intf) return; // already finished
|
||||
if (rtl.debug_load_units) rtl.debug('loadintf: "'+module.$name+'"');
|
||||
if (module.$state===rtl.m_loading_intf)
|
||||
rtl.error('unit cycle detected "'+module.$name+'"');
|
||||
module.$state=rtl.m_loading_intf;
|
||||
// load interfaces of interface useslist
|
||||
rtl.loaduseslist(module,module.$intfuseslist,rtl.loadintf);
|
||||
// run interface
|
||||
if (rtl.debug_load_units) rtl.debug('loadintf: run intf of '+module.$name);
|
||||
module.$code(module.$intfuseslist,module);
|
||||
if (rtl.debug_load_units) rtl.debug('loadintf: run intf of "'+module.$name+'"');
|
||||
module.$intfcode(module.$intfuseslist);
|
||||
// success
|
||||
module.$state=rtl.m_intf_loaded;
|
||||
// Note: units only used in implementations are not yet loaded (not even their interfaces)
|
||||
@ -140,7 +153,7 @@ var rtl = {
|
||||
if (useslist==undefined) return;
|
||||
for (var i in useslist){
|
||||
var unitname=useslist[i];
|
||||
if (rtl.debug_load_units) rtl.debug('loaduseslist of "'+module.name+'" uses="'+unitname+'"');
|
||||
if (rtl.debug_load_units) rtl.debug('loaduseslist of "'+module.$name+'" uses="'+unitname+'"');
|
||||
if (pas[unitname]==undefined)
|
||||
rtl.error('module "'+module.$name+'" misses "'+unitname+'"');
|
||||
f(pas[unitname]);
|
||||
@ -149,61 +162,106 @@ var rtl = {
|
||||
|
||||
loadimpl: function(module){
|
||||
if (module.$state>=rtl.m_loading_impl) return; // already processing
|
||||
if (module.$state<rtl.m_loading_intf) rtl.loadintf(module);
|
||||
if (rtl.debug_load_units) rtl.debug('loadimpl: '+module.$name+' load uses');
|
||||
if (module.$state<rtl.m_intf_loaded) rtl.error('loadimpl: interface not loaded of "'+module.$name+'"');
|
||||
if (rtl.debug_load_units) rtl.debug('loadimpl: load uses of "'+module.$name+'"');
|
||||
module.$state=rtl.m_loading_impl;
|
||||
// load interfaces of implementation useslist
|
||||
rtl.loaduseslist(module,module.$impluseslist,rtl.loadintf);
|
||||
// load implementation of interfaces useslist
|
||||
rtl.loaduseslist(module,module.$intfuseslist,rtl.loadimpl);
|
||||
// load implementation of implementation useslist
|
||||
rtl.loaduseslist(module,module.$impluseslist,rtl.loadimpl);
|
||||
// Note: At this point all interfaces used by this unit are loaded. If
|
||||
// there are implementation uses cycles some used units might not yet be
|
||||
// initialized. This is by design.
|
||||
|
||||
// there are implementation uses cycles some used units might not yet be
|
||||
// initialized. This is by design.
|
||||
// run implementation
|
||||
if (rtl.debug_load_units) rtl.debug('loadimpl: run impl of "'+module.$name+'"');
|
||||
if (rtl.isFunction(module.$implcode)) module.$implcode(module.$impluseslist);
|
||||
// run initialization
|
||||
if (rtl.debug_load_units) rtl.debug('loadimpl: '+module.$name+' run init');
|
||||
if (rtl.debug_load_units) rtl.debug('loadimpl: run init of "'+module.$name+'"');
|
||||
module.$state=rtl.m_initializing;
|
||||
if (rtl.isFunction(module.$init))
|
||||
module.$init();
|
||||
if (rtl.isFunction(module.$init)) module.$init();
|
||||
// unit initialized
|
||||
module.$state=rtl.m_initialized;
|
||||
},
|
||||
|
||||
createCallback: function(scope, fnname){
|
||||
var cb = function(){
|
||||
return scope[fnname].apply(scope,arguments);
|
||||
createCallback: function(scope, fn){
|
||||
var cb;
|
||||
if (typeof(fn)==='string'){
|
||||
cb = function(){
|
||||
return scope[fn].apply(scope,arguments);
|
||||
};
|
||||
} else {
|
||||
cb = function(){
|
||||
return fn.apply(scope,arguments);
|
||||
};
|
||||
};
|
||||
cb.scope = scope;
|
||||
cb.fnname = fnname;
|
||||
cb.fn = fn;
|
||||
return cb;
|
||||
},
|
||||
|
||||
cloneCallback: function(cb){
|
||||
return rtl.createCallback(cb.scope,cb.fnname);
|
||||
return rtl.createCallback(cb.scope,cb.fn);
|
||||
},
|
||||
|
||||
eqCallback: function(a,b){
|
||||
if (a==null){
|
||||
return (b==null);
|
||||
// can be a function or a function wrapper
|
||||
if (a==b){
|
||||
return true;
|
||||
} else {
|
||||
return (b!=null) && (a.scope==b.scope) && (a.fnname==b.fnname);
|
||||
return (a!=null) && (b!=null) && (a.fn) && (a.scope===b.scope) && (a.fn==b.fn);
|
||||
}
|
||||
},
|
||||
|
||||
createClass: function(owner,name,ancestor,initfn){
|
||||
initClass: function(c,parent,name,initfn){
|
||||
parent[name] = c;
|
||||
c.$classname = name;
|
||||
if ((parent.$module) && (parent.$module.$impl===parent)) parent=parent.$module;
|
||||
c.$parent = parent;
|
||||
c.$fullname = parent.$name+'.'+name;
|
||||
if (rtl.isModule(parent)){
|
||||
c.$module = parent;
|
||||
c.$name = name;
|
||||
} else {
|
||||
c.$module = parent.$module;
|
||||
c.$name = parent.name+'.'+name;
|
||||
};
|
||||
// rtti
|
||||
if (rtl.debug_rtti) rtl.debug('initClass '+c.$fullname);
|
||||
var t = c.$module.$rtti.$Class(c.$name,{ "class": c, module: parent });
|
||||
c.$rtti = t;
|
||||
if (rtl.isObject(c.$ancestor)) t.ancestor = c.$ancestor.$rtti;
|
||||
if (!t.ancestor) t.ancestor = null;
|
||||
// init members
|
||||
initfn.call(c);
|
||||
},
|
||||
|
||||
createClass: function(parent,name,ancestor,initfn){
|
||||
// create a normal class,
|
||||
// ancestor must be null or a normal class,
|
||||
// the root ancestor can be an external class
|
||||
var c = null;
|
||||
if (ancestor != null){
|
||||
c = Object.create(ancestor);
|
||||
c.$ancestor = ancestor; // c.$ancestor == Object.getPrototypeOf(c)
|
||||
c.$ancestor = ancestor;
|
||||
// Note:
|
||||
// if root is an "object" then c.$ancestor === Object.getPrototypeOf(c)
|
||||
// if root is a "function" then c.$ancestor === c.__proto__, Object.getPrototypeOf(c) returns the root
|
||||
} else {
|
||||
c = {};
|
||||
c.$create = function(fnname,args){
|
||||
var o = Object.create(this);
|
||||
o.$class = this; // Note: o.$class == Object.getPrototypeOf(o)
|
||||
if (args == undefined) args = [];
|
||||
var o = Object.create(this);
|
||||
o.$class = this; // Note: o.$class === Object.getPrototypeOf(o)
|
||||
o.$init();
|
||||
o[fnname].apply(o,args);
|
||||
o.AfterConstruction();
|
||||
try{
|
||||
o[fnname].apply(o,args);
|
||||
o.AfterConstruction();
|
||||
} catch($e){
|
||||
o.$destroy;
|
||||
throw $e;
|
||||
}
|
||||
return o;
|
||||
};
|
||||
c.$destroy = function(fnname){
|
||||
@ -212,50 +270,179 @@ var rtl = {
|
||||
this.$final;
|
||||
};
|
||||
};
|
||||
c.$classname = name;
|
||||
c.$name = owner.$name+'.'+name;
|
||||
c.$unitname = rtl.isString(owner.$unitname) ? owner.$unitname : owner.$name;
|
||||
owner[name] = c;
|
||||
initfn.call(c);
|
||||
rtl.initClass(c,parent,name,initfn);
|
||||
},
|
||||
|
||||
as: function(instance,typ){
|
||||
if(typ.isPrototypeOf(instance)) return instance;
|
||||
throw pas.System.EInvalidCast.$create("create");
|
||||
},
|
||||
|
||||
arraySetLength: function(arr,newlength,defaultvalue){
|
||||
var oldlen = arr.length;
|
||||
if (oldlen==newlength) return;
|
||||
arr.length = newlength;
|
||||
if (rtl.isArray(defaultvalue)){
|
||||
for (var i=oldlen; i<newlength; i++) arr[i]=[]; // new array
|
||||
} else if (rtl.isFunction(defaultvalue)){
|
||||
for (var i=oldlen; i<newlength; i++) arr[i]=new defaultvalue(); // new record
|
||||
} else {
|
||||
for (var i=oldlen; i<newlength; i++) arr[i]=defaultvalue;
|
||||
}
|
||||
return arr;
|
||||
},
|
||||
|
||||
arrayNewMultiDim: function(dims,defaultvalue){
|
||||
function create(dim){
|
||||
if (dim == dims.length-1){
|
||||
return rtl.arraySetLength([],dims[dim],defaultvalue);
|
||||
createClassExt: function(parent,name,ancestor,newinstancefnname,initfn){
|
||||
// Create a class using an external ancestor.
|
||||
// If newinstancefnname is given, use that function to create the new object.
|
||||
// If exist call BeforeDestruction and AfterConstruction.
|
||||
var c = null;
|
||||
c = Object.create(ancestor);
|
||||
c.$create = function(fnname,args){
|
||||
if (args == undefined) args = [];
|
||||
var o = null;
|
||||
if (newinstancefnname.length>0){
|
||||
o = this[newinstancefnname](fnname,args);
|
||||
} else {
|
||||
o = Object.create(this);
|
||||
}
|
||||
var a = [];
|
||||
var count = dims[dim];
|
||||
a.length = count;
|
||||
for(var i=0; i<count; i++) a[i] = create(dim+1);
|
||||
return a;
|
||||
o.$class = this; // Note: o.$class === Object.getPrototypeOf(o)
|
||||
o.$init();
|
||||
try{
|
||||
o[fnname].apply(o,args);
|
||||
if (o.AfterConstruction) o.AfterConstruction();
|
||||
} catch($e){
|
||||
o.$destroy;
|
||||
throw $e;
|
||||
}
|
||||
return o;
|
||||
};
|
||||
return create(0);
|
||||
c.$destroy = function(fnname){
|
||||
if (this.BeforeDestruction) this.BeforeDestruction();
|
||||
this[fnname]();
|
||||
this.$final;
|
||||
};
|
||||
rtl.initClass(c,parent,name,initfn);
|
||||
},
|
||||
|
||||
tObjectDestroy: "Destroy",
|
||||
|
||||
free: function(obj,name){
|
||||
if (obj[name]==null) return;
|
||||
obj[name].$destroy(rtl.tObjectDestroy);
|
||||
obj[name]=null;
|
||||
},
|
||||
|
||||
freeLoc: function(obj){
|
||||
if (obj==null) return;
|
||||
obj.$destroy(rtl.tObjectDestroy);
|
||||
return null;
|
||||
},
|
||||
|
||||
is: function(descendant,type){
|
||||
return type.isPrototypeOf(descendant) || (descendant===type);
|
||||
},
|
||||
|
||||
isExt: function(instance,type){
|
||||
// Notes:
|
||||
// isPrototypeOf and instanceof return false on equal
|
||||
// isPrototypeOf does not work for Date.isPrototypeOf(new Date())
|
||||
// so if isPrototypeOf is false test with instanceof
|
||||
// instanceof needs a function on right side
|
||||
if (instance == null) return false; // Note: ==null checks for undefined
|
||||
if ((typeof(type) !== 'object') && (typeof(type) !== 'function')) return false;
|
||||
if (instance === type) return true;
|
||||
if (type.isPrototypeOf && type.isPrototypeOf(instance)) return true;
|
||||
if ((typeof type == 'function') && (instance instanceof type)) return true;
|
||||
return false;
|
||||
},
|
||||
|
||||
EInvalidCast: null,
|
||||
|
||||
as: function(instance,type){
|
||||
if(rtl.is(instance,type)) return instance;
|
||||
throw rtl.EInvalidCast.$create("create");
|
||||
},
|
||||
|
||||
asExt: function(instance,type){
|
||||
if(rtl.isExt(instance,type)) return instance;
|
||||
throw rtl.EInvalidCast.$create("create");
|
||||
},
|
||||
|
||||
length: function(arr){
|
||||
return (arr == null) ? 0 : arr.length;
|
||||
},
|
||||
|
||||
arraySetLength: function(arr,defaultvalue,newlength){
|
||||
// multi dim: (arr,defaultvalue,dim1,dim2,...)
|
||||
if (arr == null) arr = [];
|
||||
var p = arguments;
|
||||
function setLength(a,argNo){
|
||||
var oldlen = a.length;
|
||||
var newlen = p[argNo];
|
||||
if (oldlen!==newlength){
|
||||
a.length = newlength;
|
||||
if (argNo === p.length-1){
|
||||
if (rtl.isArray(defaultvalue)){
|
||||
for (var i=oldlen; i<newlen; i++) a[i]=[]; // nested array
|
||||
} else if (rtl.isFunction(defaultvalue)){
|
||||
for (var i=oldlen; i<newlen; i++) a[i]=new defaultvalue(); // e.g. record
|
||||
} else if (rtl.isObject(defaultvalue)) {
|
||||
for (var i=oldlen; i<newlen; i++) a[i]={}; // e.g. set
|
||||
} else {
|
||||
for (var i=oldlen; i<newlen; i++) a[i]=defaultvalue;
|
||||
}
|
||||
} else {
|
||||
for (var i=oldlen; i<newlen; i++) a[i]=[]; // nested array
|
||||
}
|
||||
}
|
||||
if (argNo < p.length-1){
|
||||
// multi argNo
|
||||
for (var i=0; i<newlen; i++) a[i]=setLength(a[i],argNo+1);
|
||||
}
|
||||
return a;
|
||||
}
|
||||
return setLength(arr,2);
|
||||
},
|
||||
|
||||
arrayClone: function(type,src,srcpos,end,dst,dstpos){
|
||||
// type: 0 for references, "refset" for calling refSet(), a function for new type()
|
||||
// src must not be null
|
||||
// This function does not range check.
|
||||
if (rtl.isFunction(type)){
|
||||
for (; srcpos<end; srcpos++) dst[dstpos++] = new type(src[srcpos]); // clone record
|
||||
} else if(isString(type) && (type === 'refSet')) {
|
||||
for (; srcpos<end; srcpos++) dst[dstpos++] = refSet(src[srcpos]); // ref set
|
||||
} else {
|
||||
for (; srcpos<end; srcpos++) dst[dstpos++] = src[srcpos]; // reference
|
||||
};
|
||||
},
|
||||
|
||||
arrayConcat: function(type){
|
||||
// type: see rtl.arrayClone
|
||||
var a = [];
|
||||
var l = 0;
|
||||
for (var i=1; i<arguments.length; i++) l+=arguments[i].length;
|
||||
a.length = l;
|
||||
l=0;
|
||||
for (var i=1; i<arguments.length; i++){
|
||||
var src = arguments[i];
|
||||
if (src == null) continue;
|
||||
rtl.arrayClone(type,src,0,src.length,a,l);
|
||||
l+=src.length;
|
||||
};
|
||||
return a;
|
||||
},
|
||||
|
||||
arrayCopy: function(type, srcarray, index, count){
|
||||
// type: see rtl.arrayClone
|
||||
// if count is missing, use srcarray.length
|
||||
if (srcarray == null) return [];
|
||||
if (index < 0) index = 0;
|
||||
if (count === undefined) count=srcarray.length;
|
||||
var end = index+count;
|
||||
if (end>scrarray.length) end = scrarray.length;
|
||||
if (index>=end) return [];
|
||||
if (type===0){
|
||||
return srcarray.slice(index,end);
|
||||
} else {
|
||||
var a = [];
|
||||
a.length = end-index;
|
||||
rtl.arrayClone(type,srcarray,index,end,a,0);
|
||||
return a;
|
||||
}
|
||||
},
|
||||
|
||||
setCharAt: function(s,index,c){
|
||||
return s.substr(0,index)+c+s.substr(index+1);
|
||||
},
|
||||
|
||||
getResStr: function(mod,name){
|
||||
var rs = mod.$resourcestrings[name];
|
||||
return rs.current?rs.current:rs.org;
|
||||
},
|
||||
|
||||
createSet: function(){
|
||||
var s = {};
|
||||
for (var i=0; i<arguments.length; i++){
|
||||
@ -342,4 +529,270 @@ var rtl = {
|
||||
for (var key in t) if (t.hasOwnProperty(key) && !s[key] && (key!='$shared')) return false;
|
||||
return true;
|
||||
},
|
||||
|
||||
strSetLength: function(s,newlen){
|
||||
var oldlen = s.length;
|
||||
if (oldlen > newlen){
|
||||
return s.substring(0,newlen);
|
||||
} else if (s.repeat){
|
||||
// Note: repeat needs ECMAScript6!
|
||||
return s+' '.repeat(newlen-oldlen);
|
||||
} else {
|
||||
while (oldlen<newlen){
|
||||
s+=' ';
|
||||
oldlen++;
|
||||
};
|
||||
return s;
|
||||
}
|
||||
},
|
||||
|
||||
spaceLeft: function(s,width){
|
||||
var l=s.length;
|
||||
if (l>=width) return s;
|
||||
if (s.repeat){
|
||||
// Note: repeat needs ECMAScript6!
|
||||
return ' '.repeat(width-l) + s;
|
||||
} else {
|
||||
while (l<width){
|
||||
s=' '+s;
|
||||
l++;
|
||||
};
|
||||
};
|
||||
},
|
||||
|
||||
floatToStr : function(d,w,p){
|
||||
// input 1-3 arguments: double, width, precision
|
||||
if (arguments.length>2){
|
||||
return rtl.spaceLeft(d.toFixed(p),w);
|
||||
} else {
|
||||
// exponent width
|
||||
var pad = "";
|
||||
var ad = Math.abs(d);
|
||||
if (ad<1.0e+10) {
|
||||
pad='00';
|
||||
} else if (ad<1.0e+100) {
|
||||
pad='0';
|
||||
}
|
||||
if (arguments.length<2) {
|
||||
w=9;
|
||||
} else if (w<9) {
|
||||
w=9;
|
||||
}
|
||||
var p = w-8;
|
||||
var s=(d>0 ? " " : "" ) + d.toExponential(p);
|
||||
s=s.replace(/e(.)/,'E$1'+pad);
|
||||
return rtl.spaceLeft(s,w);
|
||||
}
|
||||
},
|
||||
|
||||
initRTTI: function(){
|
||||
if (rtl.debug_rtti) rtl.debug('initRTTI');
|
||||
|
||||
// base types
|
||||
rtl.tTypeInfo = { name: "tTypeInfo" };
|
||||
function newBaseTI(name,kind,ancestor){
|
||||
if (!ancestor) ancestor = rtl.tTypeInfo;
|
||||
if (rtl.debug_rtti) rtl.debug('initRTTI.newBaseTI "'+name+'" '+kind+' ("'+ancestor.name+'")');
|
||||
var t = Object.create(ancestor);
|
||||
t.name = name;
|
||||
t.kind = kind;
|
||||
rtl[name] = t;
|
||||
return t;
|
||||
};
|
||||
function newBaseInt(name,minvalue,maxvalue,ordtype){
|
||||
var t = newBaseTI(name,1 /* tkInteger */,rtl.tTypeInfoInteger);
|
||||
t.minvalue = minvalue;
|
||||
t.maxvalue = maxvalue;
|
||||
t.ordtype = ordtype;
|
||||
return t;
|
||||
};
|
||||
newBaseTI("tTypeInfoInteger",1 /* tkInteger */);
|
||||
newBaseInt("shortint",-0x80,0x7f,0);
|
||||
newBaseInt("byte",0,0xff,1);
|
||||
newBaseInt("smallint",-0x8000,0x7fff,2);
|
||||
newBaseInt("word",0,0xffff,3);
|
||||
newBaseInt("longint",-0x80000000,0x7fffffff,4);
|
||||
newBaseInt("longword",0,0xffffffff,5);
|
||||
newBaseInt("nativeint",-0x10000000000000,0xfffffffffffff,6);
|
||||
newBaseInt("nativeuint",0,0xfffffffffffff,7);
|
||||
newBaseTI("char",2 /* tkChar */);
|
||||
newBaseTI("string",3 /* tkString */);
|
||||
newBaseTI("tTypeInfoEnum",4 /* tkEnumeration */,rtl.tTypeInfoInteger);
|
||||
newBaseTI("tTypeInfoSet",5 /* tkSet */);
|
||||
newBaseTI("double",6 /* tkDouble */);
|
||||
newBaseTI("boolean",7 /* tkBool */);
|
||||
newBaseTI("tTypeInfoProcVar",8 /* tkProcVar */);
|
||||
newBaseTI("tTypeInfoMethodVar",9 /* tkMethod */,rtl.tTypeInfoProcVar);
|
||||
newBaseTI("tTypeInfoArray",10 /* tkArray */);
|
||||
newBaseTI("tTypeInfoDynArray",11 /* tkDynArray */);
|
||||
newBaseTI("tTypeInfoPointer",15 /* tkPointer */);
|
||||
var t = newBaseTI("pointer",15 /* tkPointer */,rtl.tTypeInfoPointer);
|
||||
t.reftype = null;
|
||||
newBaseTI("jsvalue",16 /* tkJSValue */);
|
||||
newBaseTI("tTypeInfoRefToProcVar",17 /* tkRefToProcVar */,rtl.tTypeInfoProcVar);
|
||||
|
||||
// member kinds
|
||||
rtl.tTypeMember = {};
|
||||
function newMember(name,kind){
|
||||
var m = Object.create(rtl.tTypeMember);
|
||||
m.name = name;
|
||||
m.kind = kind;
|
||||
rtl[name] = m;
|
||||
};
|
||||
newMember("tTypeMemberField",1); // tmkField
|
||||
newMember("tTypeMemberMethod",2); // tmkMethod
|
||||
newMember("tTypeMemberProperty",3); // tmkProperty
|
||||
|
||||
// base object for storing members: a simple object
|
||||
rtl.tTypeMembers = {};
|
||||
|
||||
// tTypeInfoStruct - base object for tTypeInfoClass and tTypeInfoRecord
|
||||
var tis = newBaseTI("tTypeInfoStruct",0);
|
||||
tis.$addMember = function(name,ancestor,options){
|
||||
if (rtl.debug_rtti){
|
||||
if (!rtl.hasString(name) || (name.charAt()==='$')) throw 'invalid member "'+name+'", this="'+this.name+'"';
|
||||
if (!rtl.is(ancestor,rtl.tTypeMember)) throw 'invalid ancestor "'+ancestor+':'+ancestor.name+'", "'+this.name+'.'+name+'"';
|
||||
if ((options!=undefined) && (typeof(options)!='object')) throw 'invalid options "'+options+'", "'+this.name+'.'+name+'"';
|
||||
};
|
||||
var t = Object.create(ancestor);
|
||||
t.name = name;
|
||||
this.members[name] = t;
|
||||
this.names.push(name);
|
||||
if (rtl.isObject(options)){
|
||||
for (var key in options) if (options.hasOwnProperty(key)) t[key] = options[key];
|
||||
};
|
||||
return t;
|
||||
};
|
||||
tis.addField = function(name,type,options){
|
||||
var t = this.$addMember(name,rtl.tTypeMemberField,options);
|
||||
if (rtl.debug_rtti){
|
||||
if (!rtl.is(type,rtl.tTypeInfo)) throw 'invalid type "'+type+'", "'+this.name+'.'+name+'"';
|
||||
};
|
||||
t.typeinfo = type;
|
||||
this.fields.push(name);
|
||||
return t;
|
||||
};
|
||||
tis.addFields = function(){
|
||||
var i=0;
|
||||
while(i<arguments.length){
|
||||
var name = arguments[i++];
|
||||
var type = arguments[i++];
|
||||
if ((i<arguments.length) && (typeof(arguments[i])==='object')){
|
||||
this.addField(name,type,arguments[i++]);
|
||||
} else {
|
||||
this.addField(name,type);
|
||||
};
|
||||
};
|
||||
};
|
||||
tis.addMethod = function(name,methodkind,params,result,options){
|
||||
var t = this.$addMember(name,rtl.tTypeMemberMethod,options);
|
||||
t.methodkind = methodkind;
|
||||
t.procsig = rtl.newTIProcSig(params);
|
||||
t.procsig.resulttype = result?result:null;
|
||||
this.methods.push(name);
|
||||
return t;
|
||||
};
|
||||
tis.addProperty = function(name,flags,result,getter,setter,options){
|
||||
var t = this.$addMember(name,rtl.tTypeMemberProperty,options);
|
||||
t.flags = flags;
|
||||
t.typeinfo = result;
|
||||
t.getter = getter;
|
||||
t.setter = setter;
|
||||
// Note: in options: params, stored, defaultvalue
|
||||
if (rtl.isArray(t.params)) t.params = rtl.newTIParams(t.params);
|
||||
this.properties.push(name);
|
||||
if (!rtl.isString(t.stored)) t.stored = "";
|
||||
return t;
|
||||
};
|
||||
tis.getField = function(index){
|
||||
return this.members[this.fields[index]];
|
||||
};
|
||||
tis.getMethod = function(index){
|
||||
return this.members[this.methods[index]];
|
||||
};
|
||||
tis.getProperty = function(index){
|
||||
return this.members[this.properties[index]];
|
||||
};
|
||||
|
||||
newBaseTI("tTypeInfoRecord",12 /* tkRecord */,rtl.tTypeInfoStruct);
|
||||
newBaseTI("tTypeInfoClass",13 /* tkClass */,rtl.tTypeInfoStruct);
|
||||
newBaseTI("tTypeInfoClassRef",14 /* tkClassRef */);
|
||||
},
|
||||
|
||||
tSectionRTTI: {
|
||||
$module: null,
|
||||
$inherited: function(name,ancestor,o){
|
||||
if (rtl.debug_rtti){
|
||||
rtl.debug('tSectionRTTI.newTI "'+(this.$module?this.$module.$name:"(no module)")
|
||||
+'"."'+name+'" ('+ancestor.name+') '+(o?'init':'forward'));
|
||||
};
|
||||
var t = this[name];
|
||||
if (t){
|
||||
if (!t.$forward) throw 'duplicate type "'+name+'"';
|
||||
if (!ancestor.isPrototypeOf(t)) throw 'typeinfo ancestor mismatch "'+name+'" ancestor="'+ancestor.name+'" t.name="'+t.name+'"';
|
||||
} else {
|
||||
t = Object.create(ancestor);
|
||||
t.name = name;
|
||||
t.module = this.module;
|
||||
this[name] = t;
|
||||
}
|
||||
if (o){
|
||||
delete t.$forward;
|
||||
for (var key in o) if (o.hasOwnProperty(key)) t[key]=o[key];
|
||||
} else {
|
||||
t.$forward = true;
|
||||
}
|
||||
return t;
|
||||
},
|
||||
$Scope: function(name,ancestor,o){
|
||||
var t=this.$inherited(name,ancestor,o);
|
||||
t.members = {};
|
||||
t.names = [];
|
||||
t.fields = [];
|
||||
t.methods = [];
|
||||
t.properties = [];
|
||||
return t;
|
||||
},
|
||||
$TI: function(name,kind,o){ var t=this.$inherited(name,rtl.tTypeInfo,o); t.kind = kind; return t; },
|
||||
$Int: function(name,o){ return this.$inherited(name,rtl.tTypeInfoInteger,o); },
|
||||
$Enum: function(name,o){ return this.$inherited(name,rtl.tTypeInfoEnum,o); },
|
||||
$Set: function(name,o){ return this.$inherited(name,rtl.tTypeInfoSet,o); },
|
||||
$StaticArray: function(name,o){ return this.$inherited(name,rtl.tTypeInfoArray,o); },
|
||||
$DynArray: function(name,o){ return this.$inherited(name,rtl.tTypeInfoDynArray,o); },
|
||||
$ProcVar: function(name,o){ return this.$inherited(name,rtl.tTypeInfoProcVar,o); },
|
||||
$RefToProcVar: function(name,o){ return this.$inherited(name,rtl.tTypeInfoRefToProcVar,o); },
|
||||
$MethodVar: function(name,o){ return this.$inherited(name,rtl.tTypeInfoMethodVar,o); },
|
||||
$Record: function(name,o){ return this.$Scope(name,rtl.tTypeInfoRecord,o); },
|
||||
$Class: function(name,o){ return this.$Scope(name,rtl.tTypeInfoClass,o); },
|
||||
$ClassRef: function(name,o){ return this.$inherited(name,rtl.tTypeInfoClassRef,o); },
|
||||
$Pointer: function(name,o){ return this.$inherited(name,rtl.tTypeInfoPointer,o); },
|
||||
},
|
||||
|
||||
newTIParam: function(param){
|
||||
// param is an array, 0=name, 1=type, 2=optional flags
|
||||
var t = {
|
||||
name: param[0],
|
||||
typeinfo: param[1],
|
||||
flags: (rtl.isNumber(param[2]) ? param[2] : 0),
|
||||
};
|
||||
return t;
|
||||
},
|
||||
|
||||
newTIParams: function(list){
|
||||
// list: optional array of [paramname,typeinfo,optional flags]
|
||||
var params = [];
|
||||
if (rtl.isArray(list)){
|
||||
for (var i=0; i<list.length; i++) params.push(rtl.newTIParam(list[i]));
|
||||
};
|
||||
return params;
|
||||
},
|
||||
|
||||
newTIProcSig: function(params,result,flags){
|
||||
var s = {
|
||||
params: rtl.newTIParams(params),
|
||||
resulttype: result,
|
||||
flags: flags
|
||||
};
|
||||
return s;
|
||||
},
|
||||
}
|
||||
|
||||
2584
utils/pas2js/docs/translation.html
Normal file
2584
utils/pas2js/docs/translation.html
Normal file
File diff suppressed because it is too large
Load Diff
57
utils/pas2js/fpmake.lpi
Normal file
57
utils/pas2js/fpmake.lpi
Normal file
@ -0,0 +1,57 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="10"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
<MainUnitHasScaledStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="fpmake"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="fpmake.pp"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<Target>
|
||||
<Filename Value="fpmake"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@ -9,7 +9,7 @@ procedure add_pas2js(const ADirectory: string);
|
||||
|
||||
Var
|
||||
P : TPackage;
|
||||
T : TTarget;
|
||||
PT,T : TTarget;
|
||||
|
||||
begin
|
||||
With Installer do
|
||||
@ -21,6 +21,7 @@ begin
|
||||
P.HomepageURL := 'www.freepascal.org';
|
||||
P.Description := 'Convert pascal sources to javascript.';
|
||||
P.Email := 'michael@freepascal.org';
|
||||
Defaults.Options.Add('-Sc');
|
||||
P.NeedLibC:= false;
|
||||
|
||||
P.Directory:=ADirectory;
|
||||
@ -28,8 +29,19 @@ begin
|
||||
P.Dependencies.Add('fcl-js');
|
||||
P.Dependencies.Add('fcl-passrc');
|
||||
P.Dependencies.Add('pastojs');
|
||||
|
||||
T:=P.Targets.AddProgram('pas2js.pp');
|
||||
T:=P.Targets.AddUnit('pas2jscompiler.pp');
|
||||
T:=P.Targets.AddUnit('pas2jsfilecache.pp');
|
||||
T:=P.Targets.AddUnit('pas2jsfileutils.pp');
|
||||
T.Dependencies.AddInclude('pas2jsfileutilsunix.inc',AllUnixOSes);
|
||||
T.Dependencies.AddInclude('pas2jsfileutilswin.inc',AllWindowsOSes);
|
||||
T:=P.Targets.AddUnit('pas2jslogger.pp');
|
||||
T:=P.Targets.AddUnit('pas2jspparser.pp');
|
||||
PT:=P.Targets.AddProgram('pas2js.pp');
|
||||
PT.Dependencies.AddUnit('pas2jscompiler');
|
||||
PT.Dependencies.AddUnit('pas2jsfileutils');
|
||||
PT.Dependencies.AddUnit('pas2jsfilecache');
|
||||
PT.Dependencies.AddUnit('pas2jslogger');
|
||||
PT.Dependencies.AddUnit('pas2jspparser');
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
26
utils/pas2js/pas2js.cfg
Normal file
26
utils/pas2js/pas2js.cfg
Normal file
@ -0,0 +1,26 @@
|
||||
#
|
||||
# Config file for pas2js compiler
|
||||
#
|
||||
|
||||
# not yet implemented: -d is the same as #DEFINE
|
||||
# not yet implemented: -u is the same as #UNDEF
|
||||
|
||||
# Write always a nice logo ;)
|
||||
-l
|
||||
|
||||
# Display Hints, Warnings and Notes
|
||||
-vwnh
|
||||
# If you don't want so much verbosity use
|
||||
#-vw
|
||||
|
||||
-Fu$CfgDir/../rtl
|
||||
-Fu$CfgDir/../packages/fcl-base
|
||||
-Fu$CfgDir/../packages/fcl-db
|
||||
-Fu$CfgDir/../packages/fpcunit
|
||||
|
||||
#IFDEF nodejs
|
||||
-Jirtl.js
|
||||
#ENDIF
|
||||
|
||||
# end.
|
||||
|
||||
@ -4,11 +4,9 @@
|
||||
<Version Value="10"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<SaveOnlyProjectUnits Value="True"/>
|
||||
<MainUnitHasUsesSectionForAllUnits Value="False"/>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
<SaveJumpHistory Value="False"/>
|
||||
<SaveFoldState Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
@ -16,9 +14,6 @@
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
@ -28,17 +23,51 @@
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
<CommandLineParams Value="/home/michael/pinc.pp"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="2">
|
||||
<Units Count="9">
|
||||
<Unit0>
|
||||
<Filename Value="pas2js.pp"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="fppas2js.pp"/>
|
||||
<Filename Value="pas2jscompiler.pp"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="Pas2jsCompiler"/>
|
||||
</Unit1>
|
||||
<Unit2>
|
||||
<Filename Value="pas2jslogger.pp"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="Pas2jsLogger"/>
|
||||
</Unit2>
|
||||
<Unit3>
|
||||
<Filename Value="pas2jsfileutils.pp"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="Pas2jsFileUtils"/>
|
||||
</Unit3>
|
||||
<Unit4>
|
||||
<Filename Value="pas2jsfilecache.pp"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="Pas2jsFileCache"/>
|
||||
</Unit4>
|
||||
<Unit5>
|
||||
<Filename Value="pas2jspparser.pp"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="Pas2jsPParser"/>
|
||||
</Unit5>
|
||||
<Unit6>
|
||||
<Filename Value="pas2js_defines.inc"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit6>
|
||||
<Unit7>
|
||||
<Filename Value="pas2jsfileutilsunix.inc"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit7>
|
||||
<Unit8>
|
||||
<Filename Value="pas2jsfileutilswin.inc"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit8>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
@ -50,6 +79,11 @@
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<AllowLabel Value="False"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
|
||||
@ -1,92 +1,77 @@
|
||||
{
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2014 by Michael Van Canneyt
|
||||
{ Author: Mattias Gaertner 2017 mattias@freepascal.org
|
||||
|
||||
Pascal to Javascript converter program.
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
Abstract:
|
||||
Command line interface for the pas2js compiler.
|
||||
}
|
||||
program pas2js;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
sysutils, classes, pparser, fppas2js, pastree, jstree, jswriter, pasresolver;
|
||||
{$IFDEF UNIX}
|
||||
cthreads, cwstring,
|
||||
{$ENDIF}
|
||||
Pas2jsFileUtils, Classes, SysUtils, CustApp,
|
||||
Pas2jsCompiler;
|
||||
|
||||
Type
|
||||
|
||||
{ TConvertPascal }
|
||||
{ TPas2jsCLI }
|
||||
|
||||
TConvertPascal = Class(TComponent)
|
||||
Procedure ConvertSource(ASource, ADest : String);
|
||||
TPas2jsCLI = class(TCustomApplication)
|
||||
private
|
||||
FCompiler: TPas2jsCompiler;
|
||||
FWriteOutputToStdErr: Boolean;
|
||||
protected
|
||||
procedure DoRun; override;
|
||||
public
|
||||
constructor Create(TheOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
property Compiler: TPas2jsCompiler read FCompiler;
|
||||
property WriteOutputToStdErr: Boolean read FWriteOutputToStdErr write FWriteOutputToStdErr;
|
||||
end;
|
||||
|
||||
|
||||
{ TConvertPascal }
|
||||
|
||||
Procedure TConvertPascal.ConvertSource(ASource, ADest: String);
|
||||
|
||||
Var
|
||||
C : TPas2JSResolver;
|
||||
M : TPasModule;
|
||||
CV : TPasToJSConverter;
|
||||
JS : TJSElement;
|
||||
W : TJSWriter;
|
||||
|
||||
procedure TPas2jsCLI.DoRun;
|
||||
var
|
||||
ParamList: TStringList;
|
||||
i: Integer;
|
||||
begin
|
||||
W:=nil;
|
||||
M:=Nil;
|
||||
CV:=Nil;
|
||||
C:=TPas2JSResolver.Create;
|
||||
ParamList:=TStringList.Create;
|
||||
try
|
||||
M:=ParseSource(C,ASource,'','',[poUseStreams]);
|
||||
CV:=TPasToJSConverter.Create;
|
||||
JS:=CV.ConvertPasElement(M,C);
|
||||
If JS=nil then
|
||||
Writeln('No result')
|
||||
else
|
||||
begin
|
||||
W:=TJSWriter.Create(ADest);
|
||||
W.Options:=[woUseUTF8,woCompactArrayLiterals,woCompactObjectLiterals,woCompactArguments];
|
||||
W.IndentSize:=2;
|
||||
W.WriteJS(JS);
|
||||
end
|
||||
for i:=1 to ParamCount do
|
||||
ParamList.Add(Params[i]);
|
||||
try
|
||||
Compiler.Run(ParamStr(0),GetCurrentDirUTF8,ParamList);
|
||||
except
|
||||
on E: ECompilerTerminate do ;
|
||||
end;
|
||||
finally
|
||||
W.Free;
|
||||
CV.Free;
|
||||
M.Free;
|
||||
C.Free;
|
||||
ParamList.Free;
|
||||
Compiler.Log.CloseOutputFile;
|
||||
end;
|
||||
|
||||
// stop program loop
|
||||
Terminate; // Keep ExitCode!
|
||||
end;
|
||||
|
||||
Var
|
||||
Src,Dest : String;
|
||||
|
||||
constructor TPas2jsCLI.Create(TheOwner: TComponent);
|
||||
begin
|
||||
Src:=Paramstr(1);
|
||||
Dest:=ParamStr(2);
|
||||
if Dest='' then
|
||||
Dest:=ChangeFileExt(Src,'.js');
|
||||
With TConvertPascal.Create(Nil) do
|
||||
try
|
||||
ConvertSource(Src,Dest);
|
||||
finally
|
||||
Free;
|
||||
end;
|
||||
With TStringList.Create do
|
||||
try
|
||||
LoadFromFile(Dest);
|
||||
Writeln(Text);
|
||||
finally
|
||||
Free;
|
||||
end;
|
||||
inherited Create(TheOwner);
|
||||
StopOnException:=True;
|
||||
FCompiler:=TPas2jsCompiler.Create;
|
||||
end;
|
||||
|
||||
destructor TPas2jsCLI.Destroy;
|
||||
begin
|
||||
FreeAndNil(FCompiler);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
var
|
||||
Application: TPas2jsCLI;
|
||||
begin
|
||||
Application:=TPas2jsCLI.Create(nil);
|
||||
Application.Run;
|
||||
Application.Free;
|
||||
end.
|
||||
|
||||
|
||||
16
utils/pas2js/pas2js_defines.inc
Normal file
16
utils/pas2js/pas2js_defines.inc
Normal file
@ -0,0 +1,16 @@
|
||||
|
||||
{$inline on}
|
||||
{$IFDEF Windows}
|
||||
{$define CaseInsensitiveFilenames}
|
||||
{$define HasUNCPaths}
|
||||
{$ENDIF}
|
||||
{$IFDEF darwin}
|
||||
{$define CaseInsensitiveFilenames}
|
||||
{$ENDIF}
|
||||
{$IF defined(CaseInsensitiveFilenames) or defined(darwin)}
|
||||
{$DEFINE NotLiteralFilenames} // e.g. HFS+ normalizes file names
|
||||
{$ENDIF}
|
||||
|
||||
{$DEFINE UTF8_RTL}
|
||||
|
||||
|
||||
3177
utils/pas2js/pas2jscompiler.pp
Normal file
3177
utils/pas2js/pas2jscompiler.pp
Normal file
File diff suppressed because it is too large
Load Diff
1097
utils/pas2js/pas2jsfilecache.pp
Normal file
1097
utils/pas2js/pas2jsfilecache.pp
Normal file
File diff suppressed because it is too large
Load Diff
676
utils/pas2js/pas2jsfileutils.pp
Normal file
676
utils/pas2js/pas2jsfileutils.pp
Normal file
@ -0,0 +1,676 @@
|
||||
{ Author: Mattias Gaertner 2017 mattias@freepascal.org
|
||||
|
||||
Abstract:
|
||||
Low level file path handling.
|
||||
}
|
||||
unit Pas2jsFileUtils;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
{$i pas2js_defines.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF Unix}
|
||||
BaseUnix,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes;
|
||||
|
||||
function FilenameIsAbsolute(const aFilename: string):boolean;
|
||||
function FilenameIsWinAbsolute(const aFilename: string):boolean;
|
||||
function FilenameIsUnixAbsolute(const aFilename: string):boolean;
|
||||
function FileIsInPath(const Filename, Path: string): boolean;
|
||||
function ChompPathDelim(const Path: string): string;
|
||||
function ExpandFileNameUTF8(const FileName: string; {const} BaseDir: string = ''): string;
|
||||
function ExpandDirectory(const aDirectory: string): string;
|
||||
function TryCreateRelativePath(const Filename, BaseDirectory: String;
|
||||
UsePointDirectory: boolean; out RelPath: String): Boolean;
|
||||
function ResolveDots(const AFilename: string): string;
|
||||
procedure ForcePathDelims(Var FileName: string);
|
||||
function GetForcedPathDelims(Const FileName: string): String;
|
||||
function ExtractFilenameOnly(const aFilename: string): string;
|
||||
function GetCurrentDirUTF8: String;
|
||||
function CompareFilenames(const File1, File2: string): integer;
|
||||
|
||||
function GetPhysicalFilename(const Filename: string;
|
||||
ExceptionOnError: boolean): string;
|
||||
function ResolveSymLinks(const Filename: string;
|
||||
{%H-}ExceptionOnError: boolean): string; // if a link is broken returns ''
|
||||
procedure FindMatchingFiles(Mask: string; MaxCount: integer; Files: TStrings);// find files, matching * and ?
|
||||
|
||||
function GetEnvironmentVariableCountUTF8: Integer;
|
||||
function GetEnvironmentStringUTF8(Index: Integer): string;
|
||||
function GetEnvironmentVariableUTF8(const EnvVar: string): String;
|
||||
|
||||
function GetNextDelimitedItem(const List: string; Delimiter: char;
|
||||
var Position: integer): string;
|
||||
|
||||
type TChangeStamp = SizeInt;
|
||||
const InvalidChangeStamp = low(TChangeStamp);
|
||||
procedure IncreaseChangeStamp(var Stamp: TChangeStamp);
|
||||
|
||||
const
|
||||
UTF8BOM = #$EF#$BB#$BF;
|
||||
EncodingUTF8 = 'UTF-8';
|
||||
EncodingSystem = 'System';
|
||||
function NormalizeEncoding(const Encoding: string): string;
|
||||
function IsNonUTF8System: boolean;// true if system encoding is not UTF-8
|
||||
function UTF8CharacterStrictLength(P: PChar): integer;
|
||||
function GetDefaultTextEncoding: string;
|
||||
function GetConsoleTextEncoding: string;
|
||||
{$IFDEF Windows}
|
||||
// AConsole - If false, it is the general system encoding,
|
||||
// if true, it is the console encoding
|
||||
function GetWindowsEncoding(AConsole: Boolean = False): string;
|
||||
{$ENDIF}
|
||||
{$IF defined(Unix) and not defined(Darwin)}
|
||||
function GetUnixEncoding: string;
|
||||
{$ENDIF}
|
||||
function IsASCII(const s: string): boolean; inline;
|
||||
|
||||
function UTF8ToUTF16(const s: string): UnicodeString;
|
||||
function UTF16ToUTF8(const s: UnicodeString): string;
|
||||
|
||||
function UTF8ToSystemCP(const s: string): string;
|
||||
function SystemCPToUTF8(const s: string): string;
|
||||
|
||||
function ConsoleToUTF8(const s: string): string;
|
||||
// converts UTF8 string to console encoding (used by Write, WriteLn)
|
||||
function UTF8ToConsole(const s: string): string;
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF Windows}
|
||||
uses Windows;
|
||||
{$ENDIF}
|
||||
|
||||
var
|
||||
EncodingValid: boolean = false;
|
||||
DefaultTextEncoding: string = EncodingSystem;
|
||||
{$IFDEF Unix}
|
||||
{$IFNDEF Darwin}
|
||||
Lang: string = '';
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
NonUTF8System: boolean = false;
|
||||
|
||||
function FilenameIsWinAbsolute(const aFilename: string): boolean;
|
||||
begin
|
||||
Result:=((length(aFilename)>=3) and
|
||||
(aFilename[1] in ['A'..'Z','a'..'z']) and (aFilename[2]=':') and (aFilename[3]in AllowDirectorySeparators))
|
||||
or ((length(aFilename)>=2) and (aFilename[1] in AllowDirectorySeparators) and (aFilename[2] in AllowDirectorySeparators));
|
||||
end;
|
||||
|
||||
function FilenameIsUnixAbsolute(const aFilename: string): boolean;
|
||||
begin
|
||||
Result:=(aFilename<>'') and (aFilename[1]='/');
|
||||
end;
|
||||
|
||||
function FileIsInPath(const Filename, Path: string): boolean;
|
||||
var
|
||||
ExpFile: String;
|
||||
ExpPath: String;
|
||||
l: integer;
|
||||
begin
|
||||
if Path='' then begin
|
||||
Result:=false;
|
||||
exit;
|
||||
end;
|
||||
ExpFile:=Filename;
|
||||
ExpPath:=IncludeTrailingPathDelimiter(Path);
|
||||
l:=length(ExpPath);
|
||||
Result:=(l>0) and (length(ExpFile)>l) and (ExpFile[l]=PathDelim)
|
||||
and (AnsiCompareFileName(ExpPath,LeftStr(ExpFile,l))=0);
|
||||
end;
|
||||
|
||||
function ChompPathDelim(const Path: string): string;
|
||||
var
|
||||
Len, MinLen: Integer;
|
||||
begin
|
||||
Result:=Path;
|
||||
if Path = '' then
|
||||
exit;
|
||||
Len:=length(Result);
|
||||
if (Result[1] in AllowDirectorySeparators) then begin
|
||||
MinLen := 1;
|
||||
{$IFDEF HasUNCPaths}
|
||||
if (Len >= 2) and (Result[2] in AllowDirectorySeparators) then
|
||||
MinLen := 2; // keep UNC '\\', chomp 'a\' to 'a'
|
||||
{$ENDIF}
|
||||
end
|
||||
else begin
|
||||
MinLen := 0;
|
||||
{$IFdef MSWindows}
|
||||
if (Len >= 3) and (Result[1] in ['a'..'z', 'A'..'Z']) and
|
||||
(Result[2] = ':') and (Result[3] in AllowDirectorySeparators)
|
||||
then
|
||||
MinLen := 3;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
while (Len > MinLen) and (Result[Len] in AllowDirectorySeparators) do dec(Len);
|
||||
if Len<length(Result) then
|
||||
SetLength(Result,Len);
|
||||
end;
|
||||
|
||||
function ExpandDirectory(const aDirectory: string): string;
|
||||
begin
|
||||
Result:=aDirectory;
|
||||
if Result='' then exit;
|
||||
Result:=ExpandFileNameUTF8(Result);
|
||||
if Result='' then exit;
|
||||
Result:=IncludeTrailingPathDelimiter(Result);
|
||||
end;
|
||||
|
||||
function TryCreateRelativePath(const Filename, BaseDirectory: String;
|
||||
UsePointDirectory: boolean; out RelPath: String): Boolean;
|
||||
{
|
||||
Returns True if it is possible to create a relative path from Source to Dest
|
||||
Function must be thread safe, so no expanding of filenames is done, since this
|
||||
is not threadsafe (at least on Windows platform)
|
||||
|
||||
- Dest and Source must either be both absolute filenames, or relative
|
||||
- Dest and Source cannot contain '..' since no expanding is done by design
|
||||
- Dest and Source must be on same drive or UNC path (Windows)
|
||||
- if both Dest and Source are relative they must at least share their base directory
|
||||
- Double PathDelims are ignored (unless they are part of the UNC convention)
|
||||
|
||||
- if UsePointDirectory is True and Result is True then if RelPath is Empty string, RelPath becomes '.'
|
||||
- if AlwaysRequireSharedBaseFolder is False then Absolute filenames need not share a basefolder
|
||||
|
||||
- if the function succeeds RelPath contains the relative path from Source to Dest,
|
||||
no PathDelimiter is appended to the end of RelPath
|
||||
|
||||
Examples:
|
||||
- Filename = /foo/bar BaseDirectory = /foo Result = True RelPath = bar
|
||||
- Filename = /foo///bar BaseDirectory = /foo// Result = True RelPath = bar
|
||||
- Filename = /foo BaseDirectory = /foo/bar Result = True RelPath = ../
|
||||
- Filename = /foo/bar BaseDirectory = /bar Result = False (no shared base directory)
|
||||
- Filename = foo/bar BaseDirectory = foo/foo Result = True RelPath = ../bar
|
||||
- Filename = foo/bar BaseDirectory = bar/foo Result = False (no shared base directory)
|
||||
- Filename = /foo BaseDirectory = bar Result = False (mixed absolute and relative)
|
||||
}
|
||||
|
||||
function IsNameChar(c: char): boolean; inline;
|
||||
begin
|
||||
Result:=(c<>#0) and not (c in AllowDirectorySeparators);
|
||||
end;
|
||||
|
||||
var
|
||||
UpDirCount: Integer;
|
||||
ResultPos: Integer;
|
||||
i: Integer;
|
||||
FileNameRestLen, SharedDirs: Integer;
|
||||
FileP, BaseP, FileEndP, BaseEndP: PChar;
|
||||
begin
|
||||
Result:=false;
|
||||
RelPath:=Filename;
|
||||
if (BaseDirectory='') or (Filename='') then exit;
|
||||
// check for different windows file drives
|
||||
if (CompareText(ExtractFileDrive(Filename),
|
||||
ExtractFileDrive(BaseDirectory))<>0)
|
||||
then
|
||||
exit;
|
||||
|
||||
FileP:=PChar(Filename);
|
||||
BaseP:=PChar(BaseDirectory);
|
||||
|
||||
//writeln('TryCreateRelativePath START File="',FileP,'" Base="',BaseP,'"');
|
||||
|
||||
// skip matching directories
|
||||
SharedDirs:=0;
|
||||
if FileP^ in AllowDirectorySeparators then begin
|
||||
if not (BaseP^ in AllowDirectorySeparators) then exit;
|
||||
repeat
|
||||
while FileP^ in AllowDirectorySeparators do inc(FileP);
|
||||
while BaseP^ in AllowDirectorySeparators do inc(BaseP);
|
||||
if (FileP^=#0) or (BaseP^=#0) then break;
|
||||
//writeln('TryCreateRelativePath check match .. File="',FileP,'" Base="',BaseP,'"');
|
||||
FileEndP:=FileP;
|
||||
BaseEndP:=BaseP;
|
||||
while IsNameChar(FileEndP^) do inc(FileEndP);
|
||||
while IsNameChar(BaseEndP^) do inc(BaseEndP);
|
||||
if CompareFilenames(copy(Filename,FileP-PChar(Filename)+1,FileEndP-FileP),
|
||||
copy(BaseDirectory,BaseP-PChar(BaseDirectory)+1,BaseEndP-BaseP))<>0
|
||||
then
|
||||
break;
|
||||
FileP:=FileEndP;
|
||||
BaseP:=BaseEndP;
|
||||
inc(SharedDirs);
|
||||
until false;
|
||||
end else if (BaseP^ in AllowDirectorySeparators) then
|
||||
exit;
|
||||
|
||||
//writeln('TryCreateRelativePath skipped matches File="',FileP,'" Base="',BaseP,'"');
|
||||
if SharedDirs=0 then exit;
|
||||
|
||||
// calculate needed '../'
|
||||
UpDirCount:=0;
|
||||
BaseEndP:=BaseP;
|
||||
while IsNameChar(BaseEndP^) do begin
|
||||
inc(UpDirCount);
|
||||
while IsNameChar(BaseEndP^) do inc(BaseEndP);
|
||||
while BaseEndP^ in AllowDirectorySeparators do inc(BaseEndP);
|
||||
end;
|
||||
|
||||
//writeln('TryCreateRelativePath UpDirCount=',UpDirCount,' File="',FileP,'" Base="',BaseP,'"');
|
||||
// create relative filename
|
||||
if (FileP^=#0) and (UpDirCount=0) then begin
|
||||
// Filename is the BaseDirectory
|
||||
if UsePointDirectory then
|
||||
RelPath:='.'
|
||||
else
|
||||
RelPath:='';
|
||||
exit(true);
|
||||
end;
|
||||
|
||||
FileNameRestLen:=length(Filename)-(FileP-PChar(Filename));
|
||||
SetLength(RelPath,3*UpDirCount+FileNameRestLen);
|
||||
ResultPos:=1;
|
||||
for i:=1 to UpDirCount do begin
|
||||
RelPath[ResultPos]:='.';
|
||||
RelPath[ResultPos+1]:='.';
|
||||
RelPath[ResultPos+2]:=PathDelim;
|
||||
inc(ResultPos,3);
|
||||
end;
|
||||
if FileNameRestLen>0 then
|
||||
Move(FileP^,RelPath[ResultPos],FileNameRestLen);
|
||||
Result:=true;
|
||||
end;
|
||||
|
||||
function ResolveDots(const AFilename: string): string;
|
||||
//trim double path delims and expand special dirs like .. and .
|
||||
//on Windows change also '/' to '\' except for filenames starting with '\\?\'
|
||||
var SrcPos, DestPos, l, DirStart: integer;
|
||||
c: char;
|
||||
MacroPos: LongInt;
|
||||
begin
|
||||
Result:=AFilename;
|
||||
{$ifdef windows}
|
||||
//Special case: everything is literal after this, even dots (this does not apply to '//?/')
|
||||
if (Pos('\\?\', AFilename) = 1) then Exit;
|
||||
{$endif}
|
||||
|
||||
l:=length(AFilename);
|
||||
SrcPos:=1;
|
||||
DestPos:=1;
|
||||
|
||||
|
||||
// trim double path delimiters and special dirs . and ..
|
||||
while (SrcPos<=l) do begin
|
||||
c:=AFilename[SrcPos];
|
||||
{$ifdef windows}
|
||||
//change / to \. The WinApi accepts both, but it leads to strange effects in other places
|
||||
if (c in AllowDirectorySeparators) then c := PathDelim;
|
||||
{$endif}
|
||||
// check for double path delims
|
||||
if (c=PathDelim) then begin
|
||||
inc(SrcPos);
|
||||
{$IFDEF Windows}
|
||||
if (DestPos>2)
|
||||
{$ELSE}
|
||||
if (DestPos>1)
|
||||
{$ENDIF}
|
||||
and (Result[DestPos-1]=PathDelim) then begin
|
||||
// skip second PathDelim
|
||||
continue;
|
||||
end;
|
||||
Result[DestPos]:=c;
|
||||
inc(DestPos);
|
||||
continue;
|
||||
end;
|
||||
// check for special dirs . and ..
|
||||
if (c='.') then begin
|
||||
if (SrcPos<l) then begin
|
||||
if (AFilename[SrcPos+1]=PathDelim)
|
||||
and ((DestPos=1) or (AFilename[SrcPos-1]=PathDelim)) then begin
|
||||
// special dir ./ or */./
|
||||
// -> skip
|
||||
inc(SrcPos,2);
|
||||
continue;
|
||||
end else if (AFilename[SrcPos+1]='.')
|
||||
and (SrcPos+1=l) or (AFilename[SrcPos+2]=PathDelim) then
|
||||
begin
|
||||
// special dir ..
|
||||
// 1. .. -> copy
|
||||
// 2. /.. -> skip .., keep /
|
||||
// 3. C:.. -> copy
|
||||
// 4. C:\.. -> skip .., keep C:\
|
||||
// 5. \\.. -> skip .., keep \\
|
||||
// 6. ../.. -> copy because if the first '..' was not resolved, the next can't neither
|
||||
// 7. dir/.. -> trim dir and ..
|
||||
// 8. dir$macro/.. -> copy
|
||||
if DestPos=1 then begin
|
||||
// 1. .. or ../ -> copy
|
||||
end else if (DestPos=2) and (Result[1]=PathDelim) then begin
|
||||
// 2. /.. -> skip .., keep /
|
||||
inc(SrcPos,2);
|
||||
continue;
|
||||
{$IFDEF Windows}
|
||||
end else if (DestPos=3) and (Result[2]=':')
|
||||
and (Result[1] in ['a'..'z','A'..'Z']) then begin
|
||||
// 3. C:.. -> copy
|
||||
end else if (DestPos=4) and (Result[2]=':') and (Result[3]=PathDelim)
|
||||
and (Result[1] in ['a'..'z','A'..'Z']) then begin
|
||||
// 4. C:\.. -> skip .., keep C:\
|
||||
inc(SrcPos,2);
|
||||
continue;
|
||||
end else if (DestPos=3) and (Result[1]=PathDelim)
|
||||
and (Result[2]=PathDelim) then begin
|
||||
// 5. \\.. -> skip .., keep \\
|
||||
inc(SrcPos,2);
|
||||
continue;
|
||||
{$ENDIF}
|
||||
end else if (DestPos>1) and (Result[DestPos-1]=PathDelim) then begin
|
||||
// */.
|
||||
if (DestPos>3)
|
||||
and (Result[DestPos-2]='.') and (Result[DestPos-3]='.')
|
||||
and ((DestPos=4) or (Result[DestPos-4]=PathDelim)) then begin
|
||||
// 6. ../.. -> copy because if the first '..' was not resolved, the next can't neither
|
||||
end else begin
|
||||
// 7. xxxdir/.. -> trim dir and skip ..
|
||||
DirStart:=DestPos-2;
|
||||
while (DirStart>1) and (Result[DirStart-1]<>PathDelim) do
|
||||
dec(DirStart);
|
||||
MacroPos:=DirStart;
|
||||
while MacroPos<DestPos do begin
|
||||
if (Result[MacroPos]='$')
|
||||
and (Result[MacroPos+1] in ['(','a'..'z','A'..'Z']) then begin
|
||||
// 8. directory contains a macro -> keep
|
||||
break;
|
||||
end;
|
||||
inc(MacroPos);
|
||||
end;
|
||||
if MacroPos=DestPos then begin
|
||||
// previous directory does not contain a macro -> remove dir/..
|
||||
DestPos:=DirStart;
|
||||
inc(SrcPos,2);
|
||||
//writeln('ResolveDots ',DestPos,' SrcPos=',SrcPos,' File="',AFilename,'" Result="',copy(Result,1,DestPos-1),'"');
|
||||
if SrcPos>l then begin
|
||||
// '..' at end of filename
|
||||
if (DestPos>1) and (Result[DestPos-1]<>PathDelim) then begin
|
||||
// foo/dir/.. -> foo
|
||||
dec(DestPos);
|
||||
end else if (DestPos=1) then begin
|
||||
// foo/.. -> .
|
||||
Result[1]:='.';
|
||||
DestPos:=2;
|
||||
end;
|
||||
end else if DestPos=1 then begin
|
||||
// e.g. 'foo/../'
|
||||
while (SrcPos<=l) and (AFilename[SrcPos] in AllowDirectorySeparators) do
|
||||
inc(SrcPos);
|
||||
end;
|
||||
continue;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end else begin
|
||||
// special dir . at end of filename
|
||||
if DestPos=1 then begin
|
||||
Result:='.';
|
||||
exit;
|
||||
end else begin
|
||||
// skip
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
// copy directory
|
||||
repeat
|
||||
Result[DestPos]:=c;
|
||||
inc(DestPos);
|
||||
inc(SrcPos);
|
||||
if (SrcPos>l) then break;
|
||||
c:=AFilename[SrcPos];
|
||||
{$ifdef windows}
|
||||
//change / to \. The WinApi accepts both, but it leads to strange effects in other places
|
||||
if (c in AllowDirectorySeparators) then c := PathDelim;
|
||||
{$endif}
|
||||
if c=PathDelim then break;
|
||||
until false;
|
||||
end;
|
||||
// trim result
|
||||
if DestPos<=length(AFilename) then
|
||||
SetLength(Result,DestPos-1);
|
||||
end;
|
||||
|
||||
procedure ForcePathDelims(Var FileName: string);
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
for i:=1 to length(FileName) do
|
||||
{$IFDEF Windows}
|
||||
if Filename[i]='/' then
|
||||
Filename[i]:='\';
|
||||
{$ELSE}
|
||||
if Filename[i]='\' then
|
||||
Filename[i]:='/';
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function GetForcedPathDelims(const FileName: string): String;
|
||||
begin
|
||||
Result:=FileName;
|
||||
ForcePathDelims(Result);
|
||||
end;
|
||||
|
||||
function ExtractFilenameOnly(const aFilename: string): string;
|
||||
var
|
||||
StartPos: Integer;
|
||||
ExtPos: Integer;
|
||||
begin
|
||||
StartPos:=length(AFilename)+1;
|
||||
while (StartPos>1)
|
||||
and not (AFilename[StartPos-1] in AllowDirectorySeparators)
|
||||
{$IFDEF Windows}and (AFilename[StartPos-1]<>':'){$ENDIF}
|
||||
do
|
||||
dec(StartPos);
|
||||
ExtPos:=length(AFilename);
|
||||
while (ExtPos>=StartPos) and (AFilename[ExtPos]<>'.') do
|
||||
dec(ExtPos);
|
||||
if (ExtPos<StartPos) then ExtPos:=length(AFilename)+1;
|
||||
Result:=copy(AFilename,StartPos,ExtPos-StartPos);
|
||||
end;
|
||||
|
||||
function CompareFilenames(const File1, File2: string): integer;
|
||||
begin
|
||||
Result:=AnsiCompareFileName(File1,File2);
|
||||
end;
|
||||
|
||||
procedure FindMatchingFiles(Mask: string; MaxCount: integer; Files: TStrings);
|
||||
var
|
||||
p: Integer;
|
||||
Path, Filename: String;
|
||||
Info: TRawByteSearchRec;
|
||||
begin
|
||||
Mask:=ResolveDots(Mask);
|
||||
p:=1;
|
||||
while p<=length(Mask) do begin
|
||||
if Mask[p] in ['*','?'] then begin
|
||||
while (p<=length(Mask)) and not (Mask[p] in AllowDirectorySeparators) do inc(p);
|
||||
Path:=LeftStr(Mask,p-1);
|
||||
if FindFirst(Path,faAnyFile,Info)=0 then begin
|
||||
repeat
|
||||
Filename:=ExtractFilePath(Path)+Info.Name;
|
||||
if p>length(Mask) then begin
|
||||
// e.g. /path/unit*.pas
|
||||
if Files.Count>=MaxCount then
|
||||
raise EListError.Create('found too many files "'+Path+'"');
|
||||
Files.Add(Filename);
|
||||
end else begin
|
||||
// e.g. /path/sub*path/...
|
||||
FindMatchingFiles(Filename+copy(Mask,p,length(Mask)),MaxCount,Files);
|
||||
end;
|
||||
until FindNext(Info)<>0;
|
||||
end;
|
||||
exit;
|
||||
end;
|
||||
inc(p);
|
||||
end;
|
||||
if FileExists(Mask) then begin
|
||||
if Files.Count>=MaxCount then
|
||||
raise EListError.Create('found too many files "'+Mask+'"');
|
||||
Files.Add(Mask);
|
||||
end;
|
||||
end;
|
||||
|
||||
function GetNextDelimitedItem(const List: string; Delimiter: char;
|
||||
var Position: integer): string;
|
||||
var
|
||||
StartPos: Integer;
|
||||
begin
|
||||
StartPos:=Position;
|
||||
while (Position<=length(List)) and (List[Position]<>Delimiter) do
|
||||
inc(Position);
|
||||
Result:=copy(List,StartPos,Position-StartPos);
|
||||
if Position<=length(List) then inc(Position); // skip Delimiter
|
||||
end;
|
||||
|
||||
procedure IncreaseChangeStamp(var Stamp: TChangeStamp);
|
||||
begin
|
||||
if Stamp<High(TChangeStamp) then
|
||||
inc(Stamp)
|
||||
else
|
||||
Stamp:=InvalidChangeStamp+1;
|
||||
end;
|
||||
|
||||
function IsNonUTF8System: boolean;
|
||||
begin
|
||||
Result:=NonUTF8System;
|
||||
end;
|
||||
|
||||
function UTF8CharacterStrictLength(P: PChar): integer;
|
||||
begin
|
||||
if p=nil then exit(0);
|
||||
if ord(p^)<%10000000 then begin
|
||||
// regular single byte character
|
||||
exit(1);
|
||||
end
|
||||
else if ord(p^)<%11000000 then begin
|
||||
// invalid single byte character
|
||||
exit(0);
|
||||
end
|
||||
else if ((ord(p^) and %11100000) = %11000000) then begin
|
||||
// should be 2 byte character
|
||||
if (ord(p[1]) and %11000000) = %10000000 then
|
||||
exit(2)
|
||||
else
|
||||
exit(0);
|
||||
end
|
||||
else if ((ord(p^) and %11110000) = %11100000) then begin
|
||||
// should be 3 byte character
|
||||
if ((ord(p[1]) and %11000000) = %10000000)
|
||||
and ((ord(p[2]) and %11000000) = %10000000) then
|
||||
exit(3)
|
||||
else
|
||||
exit(0);
|
||||
end
|
||||
else if ((ord(p^) and %11111000) = %11110000) then begin
|
||||
// should be 4 byte character
|
||||
if ((ord(p[1]) and %11000000) = %10000000)
|
||||
and ((ord(p[2]) and %11000000) = %10000000)
|
||||
and ((ord(p[3]) and %11000000) = %10000000) then
|
||||
exit(4)
|
||||
else
|
||||
exit(0);
|
||||
end else
|
||||
exit(0);
|
||||
end;
|
||||
|
||||
function GetDefaultTextEncoding: string;
|
||||
begin
|
||||
if EncodingValid then begin
|
||||
Result:=DefaultTextEncoding;
|
||||
exit;
|
||||
end;
|
||||
|
||||
{$IFDEF Windows}
|
||||
Result:=GetWindowsEncoding;
|
||||
{$ELSE}
|
||||
{$IFDEF Darwin}
|
||||
Result:=EncodingUTF8;
|
||||
{$ELSE}
|
||||
Lang := GetEnvironmentVariable('LC_ALL');
|
||||
if Lang='' then begin
|
||||
Lang := GetEnvironmentVariable('LC_MESSAGES');
|
||||
if Lang='' then
|
||||
Lang := GetEnvironmentVariable('LANG');
|
||||
end;
|
||||
Result:=GetUnixEncoding;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
Result:=NormalizeEncoding(Result);
|
||||
|
||||
DefaultTextEncoding:=Result;
|
||||
EncodingValid:=true;
|
||||
end;
|
||||
|
||||
function NormalizeEncoding(const Encoding: string): string;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
Result:=LowerCase(Encoding);
|
||||
for i:=length(Result) downto 1 do
|
||||
if Result[i]='-' then Delete(Result,i,1);
|
||||
end;
|
||||
|
||||
function IsASCII(const s: string): boolean; inline;
|
||||
var
|
||||
p: PChar;
|
||||
begin
|
||||
if s='' then exit(true);
|
||||
p:=PChar(s);
|
||||
repeat
|
||||
case p^ of
|
||||
#0: if p-PChar(s)=length(s) then exit(true);
|
||||
#128..#255: exit(false);
|
||||
end;
|
||||
inc(p);
|
||||
until false;
|
||||
end;
|
||||
|
||||
function UTF8ToUTF16(const s: string): UnicodeString;
|
||||
begin
|
||||
Result:=UTF8Decode(s);
|
||||
end;
|
||||
|
||||
function UTF16ToUTF8(const s: UnicodeString): string;
|
||||
begin
|
||||
if s='' then exit('');
|
||||
Result:=UTF8Encode(s);
|
||||
// prevent UTF8 codepage appear in the strings - we don't need codepage
|
||||
// conversion magic
|
||||
SetCodePage(RawByteString(Result), CP_ACP, False);
|
||||
end;
|
||||
|
||||
{$IFDEF Unix}
|
||||
{$I pas2jsfileutilsunix.inc}
|
||||
{$ENDIF}
|
||||
{$IFDEF Windows}
|
||||
{$I pas2jsfileutilswin.inc}
|
||||
{$ENDIF}
|
||||
|
||||
procedure InternalInit;
|
||||
begin
|
||||
SetMultiByteConversionCodePage(CP_UTF8);
|
||||
// SetMultiByteFileSystemCodePage(CP_UTF8); not needed, this is the default under Windows
|
||||
SetMultiByteRTLFileSystemCodePage(CP_UTF8);
|
||||
|
||||
GetDefaultTextEncoding;
|
||||
{$IFDEF Windows}
|
||||
NonUTF8System:=true;
|
||||
{$ELSE}
|
||||
NonUTF8System:=SysUtils.CompareText(DefaultTextEncoding,'UTF8')<>0;
|
||||
{$ENDIF}
|
||||
InitPlatform;
|
||||
end;
|
||||
|
||||
initialization
|
||||
InternalInit;
|
||||
finalization
|
||||
FinalizePlatform;
|
||||
end.
|
||||
|
||||
206
utils/pas2js/pas2jsfileutilsunix.inc
Normal file
206
utils/pas2js/pas2jsfileutilsunix.inc
Normal file
@ -0,0 +1,206 @@
|
||||
{%MainUnit pas2jsfileutils.pas}
|
||||
|
||||
function FilenameIsAbsolute(const aFilename: string): boolean;
|
||||
begin
|
||||
Result:=FilenameIsUnixAbsolute(aFilename);
|
||||
end;
|
||||
|
||||
function ExpandFileNameUTF8(const FileName: string; BaseDir: string): string;
|
||||
var
|
||||
IsAbs: Boolean;
|
||||
CurDir, HomeDir, Fn: String;
|
||||
begin
|
||||
Fn := FileName;
|
||||
ForcePathDelims(Fn);
|
||||
IsAbs := FileNameIsUnixAbsolute(Fn);
|
||||
if (not IsAbs) then
|
||||
begin
|
||||
CurDir := GetCurrentDirUtf8;
|
||||
if ((Length(Fn) > 1) and (Fn[1] = '~') and (Fn[2] = '/')) or (Fn = '~') then
|
||||
begin
|
||||
HomeDir := GetEnvironmentVariableUTF8('HOME');
|
||||
if not FileNameIsUnixAbsolute(HomeDir) then
|
||||
HomeDir := ExpandFileNameUtf8(HomeDir,'');
|
||||
Fn := HomeDir + Copy(Fn,2,length(Fn));
|
||||
IsAbs := True;
|
||||
end;
|
||||
end;
|
||||
if IsAbs then
|
||||
begin
|
||||
Result := ResolveDots(Fn);
|
||||
end
|
||||
else
|
||||
begin
|
||||
if (BaseDir = '') then
|
||||
Fn := IncludeTrailingPathDelimiter(CurDir) + Fn
|
||||
else
|
||||
Fn := IncludeTrailingPathDelimiter(BaseDir) + Fn;
|
||||
Fn := ResolveDots(Fn);
|
||||
//if BaseDir is not absolute then this needs to be expanded as well
|
||||
if not FileNameIsUnixAbsolute(Fn) then
|
||||
Fn := ExpandFileNameUtf8(Fn, '');
|
||||
Result := Fn;
|
||||
end;
|
||||
end;
|
||||
|
||||
function GetCurrentDirUTF8: String;
|
||||
begin
|
||||
Result:=GetCurrentDir;
|
||||
end;
|
||||
|
||||
function GetPhysicalFilename(const Filename: string; ExceptionOnError: boolean
|
||||
): string;
|
||||
var
|
||||
OldPath: String;
|
||||
NewPath: String;
|
||||
p: PChar;
|
||||
begin
|
||||
Result:=Filename;
|
||||
p:=PChar(Result);
|
||||
repeat
|
||||
while p^='/' do
|
||||
inc(p);
|
||||
if p^=#0 then exit;
|
||||
if p^<>'/' then
|
||||
begin
|
||||
repeat
|
||||
inc(p);
|
||||
until p^ in [#0,'/'];
|
||||
OldPath:=LeftStr(Result,p-PChar(Result));
|
||||
NewPath:=ResolveSymLinks(OldPath,ExceptionOnError);
|
||||
if NewPath='' then exit('');
|
||||
if OldPath<>NewPath then
|
||||
begin
|
||||
Result:=NewPath+copy(Result,length(OldPath)+1,length(Result));
|
||||
p:=PChar(Result)+length(NewPath);
|
||||
end;
|
||||
end;
|
||||
until false;
|
||||
end;
|
||||
|
||||
function ResolveSymLinks(const Filename: string; ExceptionOnError: boolean
|
||||
): string;
|
||||
var
|
||||
LinkFilename: string;
|
||||
AText: string;
|
||||
Depth: Integer;
|
||||
begin
|
||||
Result:=Filename;
|
||||
Depth:=0;
|
||||
while Depth<12 do begin
|
||||
inc(Depth);
|
||||
LinkFilename:=fpReadLink(Result);
|
||||
if LinkFilename='' then begin
|
||||
AText:='"'+Filename+'"';
|
||||
case fpGetErrno() of
|
||||
ESysEAcces:
|
||||
AText:='read access denied for '+AText;
|
||||
ESysENoEnt:
|
||||
AText:='a directory component in '+AText
|
||||
+' does not exist or is a dangling symlink';
|
||||
ESysENotDir:
|
||||
AText:='a directory component in '+AText+' is not a directory';
|
||||
ESysENoMem:
|
||||
AText:='insufficient memory';
|
||||
ESysELoop:
|
||||
AText:=AText+' has a circular symbolic link';
|
||||
else
|
||||
// not a symbolic link, just a regular file
|
||||
exit;
|
||||
end;
|
||||
if (not ExceptionOnError) then begin
|
||||
Result:='';
|
||||
exit;
|
||||
end;
|
||||
raise EFOpenError.Create(AText);
|
||||
end else begin
|
||||
if not FilenameIsAbsolute(LinkFilename) then
|
||||
Result:=ExtractFilePath(Result)+LinkFilename
|
||||
else
|
||||
Result:=LinkFilename;
|
||||
end;
|
||||
end;
|
||||
// probably an endless loop
|
||||
if ExceptionOnError then
|
||||
raise EFOpenError.Create('too many links, maybe an endless loop.')
|
||||
else
|
||||
Result:='';
|
||||
end;
|
||||
|
||||
function GetEnvironmentVariableCountUTF8: Integer;
|
||||
begin
|
||||
Result:=GetEnvironmentVariableCount;
|
||||
end;
|
||||
|
||||
function GetEnvironmentStringUTF8(Index: Integer): string;
|
||||
begin
|
||||
Result:=ConsoleToUTF8(GetEnvironmentString(Index));
|
||||
end;
|
||||
|
||||
function GetEnvironmentVariableUTF8(const EnvVar: string): String;
|
||||
begin
|
||||
Result:=ConsoleToUTF8(GetEnvironmentVariable(EnvVar));
|
||||
end;
|
||||
|
||||
{$IFNDEF Darwin}
|
||||
function GetUnixEncoding: string;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
Result:=EncodingSystem;
|
||||
i:=pos('.',Lang);
|
||||
if (i>0) and (i<=length(Lang)) then
|
||||
Result:=copy(Lang,i+1,length(Lang)-i);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
function GetConsoleTextEncoding: string;
|
||||
begin
|
||||
Result:=GetDefaultTextEncoding;
|
||||
end;
|
||||
|
||||
function UTF8ToSystemCP(const s: string): string;
|
||||
begin
|
||||
if NonUTF8System and not IsASCII(s) then
|
||||
begin
|
||||
Result:=UTF8ToAnsi(s);
|
||||
// prevent UTF8 codepage appear in the strings - we don't need codepage
|
||||
// conversion magic
|
||||
SetCodePage(RawByteString(Result), StringCodePage(s), False);
|
||||
end
|
||||
else
|
||||
Result:=s;
|
||||
end;
|
||||
|
||||
function SystemCPToUTF8(const s: string): string;
|
||||
begin
|
||||
if NonUTF8System and not IsASCII(s) then
|
||||
begin
|
||||
Result:=AnsiToUTF8(s);
|
||||
// prevent UTF8 codepage appear in the strings - we don't need codepage
|
||||
// conversion magic
|
||||
SetCodePage(RawByteString(Result), StringCodePage(s), False);
|
||||
end
|
||||
else
|
||||
Result:=s;
|
||||
end;
|
||||
|
||||
function ConsoleToUTF8(const s: string): string;
|
||||
begin
|
||||
Result:=SystemCPToUTF8(s);
|
||||
end;
|
||||
|
||||
function UTF8ToConsole(const s: string): string;
|
||||
begin
|
||||
Result:=UTF8ToSystemCP(s);
|
||||
end;
|
||||
|
||||
procedure InitPlatform;
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
procedure FinalizePlatform;
|
||||
begin
|
||||
|
||||
end;
|
||||
606
utils/pas2js/pas2jsfileutilswin.inc
Normal file
606
utils/pas2js/pas2jsfileutilswin.inc
Normal file
@ -0,0 +1,606 @@
|
||||
{%MainUnit pas2jsfileutils.pas}
|
||||
|
||||
{$IF DEFINED(UTF8_RTL) AND NOT DEFINED(WINCE)}
|
||||
{$DEFINE ArgsWAsUTF8}
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF OldStuff}
|
||||
//Function prototypes
|
||||
var _ParamStrUtf8: Function(Param: Integer): string;
|
||||
{$ENDIF}
|
||||
|
||||
var
|
||||
ArgsW: Array of WideString;
|
||||
ArgsWCount: Integer; // length(ArgsW)+1
|
||||
{$IFDEF ArgsWAsUTF8}
|
||||
ArgsUTF8: Array of String; // the ArgsW array as UTF8
|
||||
OldArgV: PPChar = nil;
|
||||
{$IFEND}
|
||||
|
||||
{$ifndef wince}
|
||||
{$IFDEF OldStuff}
|
||||
function ParamStrUtf8Ansi(Param: Integer): String;
|
||||
begin
|
||||
Result:=ObjPas.ParamStr(Param);
|
||||
end;
|
||||
{$ENDIF}
|
||||
{$endif wince}
|
||||
|
||||
{$IFDEF OldStuff}
|
||||
function ParamStrUtf8Wide(Param: Integer): String;
|
||||
begin
|
||||
if ArgsWCount <> ParamCount then
|
||||
begin
|
||||
//DebugLn('Error: ParamCount <> ArgsWCount!');
|
||||
Result := ObjPas.ParamStr(Param);
|
||||
end
|
||||
else
|
||||
begin
|
||||
if (Param <= ArgsWCount) then
|
||||
{$IFDEF ACP_RTL}
|
||||
Result := String(UnicodeString(ArgsW[Param]))
|
||||
{$ELSE}
|
||||
Result := UTF16ToUTF8(ArgsW[Param])
|
||||
{$ENDIF ACP_RTL}
|
||||
else
|
||||
Result := '';
|
||||
end;
|
||||
end;
|
||||
{$ENDIF oldstuff}
|
||||
|
||||
{$IFDEF ArgsWAsUTF8}
|
||||
procedure SetupArgvAsUtf8;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
SetLength(ArgsUTF8,length(ArgsW));
|
||||
OldArgV:=argv;
|
||||
GetMem(argv,SizeOf(Pointer)*length(ArgsW));
|
||||
for i:=0 to length(ArgsW)-1 do
|
||||
begin
|
||||
ArgsUTF8[i]:=ArgsW{%H-}[i];
|
||||
argv[i]:=PChar(ArgsUTF8[i]);
|
||||
end;
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
procedure SetupCommandlineParametersWide;
|
||||
var
|
||||
ArgLen, Start, CmdLen, i, j: SizeInt;
|
||||
Quote : Boolean;
|
||||
Buf: array[0..259] of WChar; // need MAX_PATH bytes, not 256!
|
||||
PCmdLineW: PWideChar;
|
||||
CmdLineW: WideString;
|
||||
|
||||
procedure AllocArg(Idx, Len:longint);
|
||||
begin
|
||||
if (Idx >= ArgsWCount) then
|
||||
SetLength(ArgsW, Idx + 1);
|
||||
SetLength(ArgsW[Idx], Len);
|
||||
end;
|
||||
|
||||
begin
|
||||
{ create commandline, it starts with the executed filename which is argv[0] }
|
||||
{ Win32 passes the command NOT via the args, but via getmodulefilename}
|
||||
ArgsWCount := 0;
|
||||
ArgLen := GetModuleFileNameW(0, @buf[0], sizeof(buf));
|
||||
|
||||
//writeln('ArgLen = ',Arglen);
|
||||
|
||||
buf[ArgLen] := #0; // be safe, no terminating 0 on XP
|
||||
allocarg(0,arglen);
|
||||
move(buf[0],ArgsW[0][1],arglen * SizeOf(WChar));
|
||||
|
||||
//writeln('ArgsW[0] = ',ArgsW[0]);
|
||||
|
||||
PCmdLineW := nil;
|
||||
{ Setup cmdline variable }
|
||||
PCmdLineW := GetCommandLineW;
|
||||
CmdLen := StrLen(PCmdLineW);
|
||||
|
||||
//writeln('StrLen(PCmdLineW) = ',CmdLen);
|
||||
|
||||
SetLength(CmdLineW, CmdLen);
|
||||
Move(PCmdLineW^, CmdLineW[1], CmdLen * SizeOf(WChar));
|
||||
|
||||
|
||||
//debugln(CmdLineW);
|
||||
//for i := 1 to CmdLen do DbgOut(DbgS(i mod 10)); debugln;
|
||||
|
||||
i := 1;
|
||||
while (i <= CmdLen) do
|
||||
begin
|
||||
//debugln('Next');
|
||||
//DbgOut('i=',DbgS(i),' CmdLineW[',DbgS(i),']=');if i<=CmdLen then debugln(CmdLineW[i]) else debugln('#0');
|
||||
//skip leading spaces
|
||||
while (i <= CmdLen) and (CmdLineW[i] <= #32) do Inc(i);
|
||||
//DbgOut('After skipping spaces: i=',DbgS(i),' CmdLineW[',DbgS(i),']=');if i<=CmdLen then debugln(CmdLineW[i]) else debugln('#0');
|
||||
if (i > CmdLen) then Break;
|
||||
Quote := False;
|
||||
Start := i;
|
||||
ArgLen := 0;
|
||||
while (i <= CmdLen) do
|
||||
begin //find next commandline parameter
|
||||
case CmdLineW[i] of
|
||||
#1..#32:
|
||||
begin
|
||||
if Quote then
|
||||
begin
|
||||
//debugln('i=',DbgS(i),': Space in Quote');
|
||||
Inc(ArgLen)
|
||||
end
|
||||
else
|
||||
begin
|
||||
//debugln('i=',DbgS(i),': Space in NOT Quote');
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
'"':
|
||||
begin
|
||||
if (i < CmdLen) and (CmdLineW[i+1] <> '"') then
|
||||
begin
|
||||
//debugln('i=',DbgS(i),': Quote := not Quote');
|
||||
Quote := not Quote
|
||||
end
|
||||
else
|
||||
begin
|
||||
//debugln('i=',DbgS(i),': Skip Quote');
|
||||
Inc(i);
|
||||
end;
|
||||
end;
|
||||
else Inc(ArgLen);
|
||||
end;//case
|
||||
Inc(i);
|
||||
end; //find next commandline parameter
|
||||
|
||||
//debugln('ArgWCount=',DbgS(ArgsWCount),' Start=',DbgS(start),' ArgLen=',DbgS(arglen),' i=',DbgS(i));
|
||||
|
||||
//we already have (a better) ArgW[0]
|
||||
if (ArgsWCount > 0) then
|
||||
begin //Process commandline parameter
|
||||
AllocArg(ArgsWCount, ArgLen);
|
||||
Quote := False;
|
||||
i := Start;
|
||||
j := 1;
|
||||
while (i <= CmdLen) do
|
||||
begin
|
||||
case CmdLineW[i] of
|
||||
#1..#32:
|
||||
begin
|
||||
if Quote then
|
||||
begin
|
||||
//if j > ArgLen then debugln('Error whitespace: j > ArgLen: j=',DbgS(j),' ArgLen=',DbgS(arglen));
|
||||
ArgsW[ArgsWCount][j] := CmdLineW[i];
|
||||
Inc(j);
|
||||
end
|
||||
else
|
||||
Break;
|
||||
end;
|
||||
'"':
|
||||
begin
|
||||
if (i < CmdLen) and (CmdLineW[i+1] <> '"') then
|
||||
Quote := not Quote
|
||||
else
|
||||
Inc(i);
|
||||
end;
|
||||
else
|
||||
begin
|
||||
//if j > ArgLen then debugln('Error Quote: j > ArgLen: j=',DbgS(j),' ArgLen=',DbgS(arglen));
|
||||
ArgsW[ArgsWCount][j] := CmdLineW[i];
|
||||
Inc(j);
|
||||
end;
|
||||
end;
|
||||
Inc(i);
|
||||
end;
|
||||
|
||||
//debugln('ArgsW[',DbgS(ArgsWCount),'] = ',ArgsW[ArgsWCount]);
|
||||
end; // Process commandline parameter
|
||||
Inc(ArgsWCount);
|
||||
|
||||
end;
|
||||
Dec(ArgsWCount);
|
||||
//Note:
|
||||
//On WinCe Argsv is a static function, so we cannot change it.
|
||||
//This might change in the future if Argsv on WinCE will be declared as a function variable
|
||||
{$IFDEF ArgsWAsUTF8}
|
||||
if DefaultSystemCodePage=CP_UTF8 then
|
||||
SetupArgvAsUtf8;
|
||||
{$IFEND}
|
||||
end;
|
||||
|
||||
function FilenameIsAbsolute(const aFilename: string): boolean;
|
||||
begin
|
||||
Result:=FilenameIsWinAbsolute(aFilename);
|
||||
end;
|
||||
|
||||
procedure GetDirUtf8(DriveNr: Byte; var Dir: String);
|
||||
{This procedure may not be threadsafe, because SetCurrentDirectory isn't}
|
||||
{$ifndef WinCE}
|
||||
var
|
||||
w, D: WideString;
|
||||
SavedDir: WideString;
|
||||
res : Integer;
|
||||
{$endif}
|
||||
begin
|
||||
{$ifdef WinCE}
|
||||
Dir := '\';
|
||||
// Previously we sent an exception here, which is correct, but this causes
|
||||
// trouble with code which isnt tested for WinCE, so lets just send a dummy result instead
|
||||
// Exception.Create('[GetCurrentDirWide] The concept of the current directory doesn''t exist in Windows CE');
|
||||
{$else}
|
||||
//writeln('GetDirWide START');
|
||||
if not (DriveNr = 0) then
|
||||
begin
|
||||
res := GetCurrentDirectoryW(0, nil);
|
||||
SetLength(SavedDir, res);
|
||||
res:=Windows.GetCurrentDirectoryW(res, @SavedDir[1]);
|
||||
SetLength(SavedDir,res);
|
||||
|
||||
D := WideChar(64 + DriveNr) + ':';
|
||||
if not SetCurrentDirectoryW(@D[1]) then
|
||||
begin
|
||||
Dir := Char(64 + DriveNr) + ':\';
|
||||
SetCurrentDirectoryW(@SavedDir[1]);
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
res := GetCurrentDirectoryW(0, nil);
|
||||
SetLength(w, res);
|
||||
res := GetCurrentDirectoryW(res, @w[1]);
|
||||
SetLength(w, res);
|
||||
Dir:=UTF16ToUTF8(w);
|
||||
if not (DriveNr = 0) then SetCurrentDirectoryW(@SavedDir[1]);
|
||||
//writeln('GetDirWide END');
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
function ExpandFileNameUtf8(const FileName: string; {const} BaseDir: String = ''): String;
|
||||
var
|
||||
IsAbs, StartsWithRoot, CanUseBaseDir : Boolean;
|
||||
{$ifndef WinCE}
|
||||
HasDrive: Boolean;
|
||||
FnDrive, CurDrive, BaseDirDrive: Char;
|
||||
{$endif}
|
||||
CurDir, Fn: String;
|
||||
begin
|
||||
//writeln('LazFileUtils.ExpandFileNameUtf8');
|
||||
//writeln('FileName = "',FileName,'"');
|
||||
//writeln('BaseDir = "',BaseDir,'"');
|
||||
|
||||
Fn := FileName;
|
||||
//if Filename uses ExtendedLengthPath scheme then it cannot be expanded
|
||||
//AND it should not be altered by ForcePathDelims or ResolveDots
|
||||
//See: http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247%28v=vs.85%29.aspx
|
||||
if (Length(Fn) > 3) and (Fn[1] = PathDelim) and (Fn[2] = PathDelim) and
|
||||
(Fn[3] = '?') and (Fn[4] = PathDelim) //Do NOT use AllowDirectorySeparators here!
|
||||
then Exit;
|
||||
ForcePathDelims(Fn);
|
||||
IsAbs := FileNameIsWinAbsolute(Fn);
|
||||
if not IsAbs then
|
||||
begin
|
||||
StartsWithRoot := (Fn = '\') or
|
||||
((Length(Fn) > 1) and
|
||||
(Fn[1] = DirectorySeparator) and
|
||||
(Fn[2] <> DirectorySeparator));
|
||||
{$ifndef WinCE}
|
||||
HasDrive := (Length(Fn) > 1) and
|
||||
(Fn[2] = ':') and
|
||||
(UpCase(Fn[1]) in ['A'..'Z']);
|
||||
|
||||
if HasDrive then
|
||||
begin
|
||||
FnDrive := UpCase(Fn[1]);
|
||||
GetDirUtf8(Byte(FnDrive)-64, CurDir{%H-});
|
||||
CurDrive := UpCase(GetCurrentDirUtf8[1]);
|
||||
end
|
||||
else
|
||||
begin
|
||||
CurDir := GetCurrentDirUtf8;
|
||||
FnDrive := UpCase(CurDir[1]);
|
||||
CurDrive := FnDrive;
|
||||
end;
|
||||
|
||||
//writeln('HasDrive = ',HasDrive,' Fn = ',Fn);
|
||||
//writeln('CurDir = ',CurDir);
|
||||
//writeln('CurDrive = ',CurDrive);
|
||||
//writeln('FnDrive = ',FnDrive);
|
||||
|
||||
if (Length(BaseDir) > 1) and (UpCase(BaseDir[1]) in ['A'..'Z']) and (BaseDir[2] = ':') then
|
||||
begin
|
||||
BaseDirDrive := BaseDir[1]
|
||||
end
|
||||
else
|
||||
begin
|
||||
if HasDrive then
|
||||
BaseDirDrive := CurDrive
|
||||
else
|
||||
BaseDirDrive := #0;
|
||||
end;
|
||||
|
||||
//You cannot use BaseDir if both FileName and BaseDir includes a drive and they are not the same
|
||||
CanUseBaseDir := ((BaseDirDrive = #0) or
|
||||
(not HasDrive) or
|
||||
(HasDrive and (FnDrive = BaseDirDrive)))
|
||||
and (BaseDir <> '');
|
||||
|
||||
//writeln('CanUseBaseDir = ',CanUseBaseDir);
|
||||
|
||||
if not HasDrive and StartsWithRoot and not CanUseBaseDir then
|
||||
begin
|
||||
//writeln('HasDrive and StartsWithRoot');
|
||||
Fn := Copy(CurDir,1,2) + Fn;
|
||||
HasDrive := True;
|
||||
IsAbs := True;
|
||||
end;
|
||||
//FileNames like C:foo, strip Driveletter + colon
|
||||
if HasDrive and not IsAbs then Delete(Fn,1,2);
|
||||
|
||||
//writeln('HasDrive = ',Hasdrive,' Fn = ',Fn);
|
||||
{$else}
|
||||
CanUseBaseDir := True;
|
||||
{$endif WinCE}
|
||||
end;
|
||||
if IsAbs then
|
||||
begin
|
||||
//writeln('IsAbs = True -> Exit');
|
||||
Result := ResolveDots(Fn);
|
||||
end
|
||||
else
|
||||
begin
|
||||
if not CanUseBaseDir or (BaseDir = '') then
|
||||
Fn := IncludeTrailingPathDelimiter(CurDir) + Fn
|
||||
else
|
||||
begin
|
||||
if (Length(Fn) > 0) and (Fn[1] = DirectorySeparator) then Delete(Fn,1,1);
|
||||
Fn := IncludeTrailingPathDelimiter(BaseDir) + Fn;
|
||||
end;
|
||||
|
||||
Fn := ResolveDots(Fn);
|
||||
//if BaseDir is something like 'z:foo\' or '\' then this needs to be expanded as well
|
||||
if not FileNameIsAbsolute(Fn) then
|
||||
Fn := ExpandFileNameUtf8(Fn, '');
|
||||
Result := Fn;
|
||||
end;
|
||||
end;
|
||||
|
||||
function GetCurrentDirUtf8: String;
|
||||
{$ifndef WinCE}
|
||||
var
|
||||
w : UnicodeString;
|
||||
res : Integer;
|
||||
{$endif}
|
||||
begin
|
||||
{$ifdef WinCE}
|
||||
Result := '\';
|
||||
// Previously we sent an exception here, which is correct, but this causes
|
||||
// trouble with code which isnt tested for WinCE, so lets just send a dummy result instead
|
||||
// Exception.Create('[GetCurrentDirWide] The concept of the current directory doesn''t exist in Windows CE');
|
||||
{$else}
|
||||
res:=GetCurrentDirectoryW(0, nil);
|
||||
SetLength(w, res);
|
||||
res:=Windows.GetCurrentDirectoryW(res, @w[1]);
|
||||
SetLength(w, res);
|
||||
Result:=UTF16ToUTF8(w);
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
function GetPhysicalFilename(const Filename: string; ExceptionOnError: boolean
|
||||
): string;
|
||||
begin
|
||||
Result:=Filename;
|
||||
if ExceptionOnError then ;
|
||||
end;
|
||||
|
||||
function ResolveSymLinks(const Filename: string; ExceptionOnError: boolean
|
||||
): string;
|
||||
begin
|
||||
Result:=Filename;
|
||||
end;
|
||||
|
||||
function GetEnvironmentVariableCountUTF8: Integer;
|
||||
var
|
||||
hp,p : PWideChar;
|
||||
begin
|
||||
Result:=0;
|
||||
p:=GetEnvironmentStringsW;
|
||||
if p=nil then exit;
|
||||
hp:=p;
|
||||
while hp^<>#0 do
|
||||
begin
|
||||
Inc(Result);
|
||||
hp:=hp+strlen(hp)+1;
|
||||
end;
|
||||
FreeEnvironmentStringsW(p);
|
||||
end;
|
||||
|
||||
function GetEnvironmentStringUTF8(Index: Integer): string;
|
||||
var
|
||||
hp,p : PWideChar;
|
||||
begin
|
||||
Result:='';
|
||||
p:=GetEnvironmentStringsW;
|
||||
if p=nil then exit;
|
||||
hp:=p;
|
||||
while (hp^<>#0) and (Index>1) do
|
||||
begin
|
||||
Dec(Index);
|
||||
hp:=hp+strlen(hp)+1;
|
||||
end;
|
||||
if (hp^<>#0) then
|
||||
Result:=UTF16ToUTF8(hp);
|
||||
FreeEnvironmentStringsW(p);
|
||||
end;
|
||||
|
||||
function GetEnvironmentVariableUTF8(const EnvVar: string): String;
|
||||
begin
|
||||
Result:=UTF16ToUTF8(SysUtils.GetEnvironmentVariable(UTF8ToUTF16(EnvVar)));
|
||||
end;
|
||||
|
||||
// AConsole - If false, it is the general system encoding,
|
||||
// if true, it is the console encoding
|
||||
function GetWindowsEncoding(AConsole: Boolean = False): string;
|
||||
var
|
||||
cp : UINT;
|
||||
{$IFDEF WinCE}
|
||||
// CP_UTF8 is missing in the windows unit of the Windows CE RTL
|
||||
const
|
||||
CP_UTF8 = 65001;
|
||||
{$ENDIF}
|
||||
begin
|
||||
if AConsole then cp := GetOEMCP
|
||||
else cp := GetACP;
|
||||
|
||||
case cp of
|
||||
CP_UTF8: Result := EncodingUTF8;
|
||||
else
|
||||
Result:='cp'+IntToStr(cp);
|
||||
end;
|
||||
end;
|
||||
|
||||
function GetConsoleTextEncoding: string;
|
||||
begin
|
||||
Result:=GetWindowsEncoding(True);
|
||||
end;
|
||||
|
||||
{$ifdef WinCe}
|
||||
function UTF8ToSystemCP(const s: string): string; inline;
|
||||
begin
|
||||
Result := s;
|
||||
end;
|
||||
{$else}
|
||||
function UTF8ToSystemCP(const s: string): string;
|
||||
// result has codepage CP_ACP
|
||||
var
|
||||
src: UnicodeString;
|
||||
len: LongInt;
|
||||
begin
|
||||
Result:=s;
|
||||
if IsASCII(Result) then begin
|
||||
// prevent codepage conversion magic
|
||||
SetCodePage(RawByteString(Result), CP_ACP, False);
|
||||
exit;
|
||||
end;
|
||||
src:=UTF8Decode(s);
|
||||
if src='' then
|
||||
exit;
|
||||
len:=WideCharToMultiByte(CP_ACP,0,PUnicodeChar(src),length(src),nil,0,nil,nil);
|
||||
SetLength(Result,len);
|
||||
if len>0 then begin
|
||||
WideCharToMultiByte(CP_ACP,0,PUnicodeChar(src),length(src),@Result[1],length(Result),nil,nil);
|
||||
// prevent codepage conversion magic
|
||||
SetCodePage(RawByteString(Result), CP_ACP, False);
|
||||
end;
|
||||
end;
|
||||
{$endif not wince}
|
||||
|
||||
{$ifdef WinCE}
|
||||
function SystemCPToUTF8(const s: string): string; inline;
|
||||
begin
|
||||
Result := SysToUtf8(s);
|
||||
end;
|
||||
{$else}
|
||||
// for all Windows supporting 8bit codepages (e.g. not WinCE)
|
||||
function SystemCPToUTF8(const s: string): string;
|
||||
// result has codepage CP_ACP
|
||||
var
|
||||
UTF16WordCnt: SizeInt;
|
||||
UTF16Str: UnicodeString;
|
||||
begin
|
||||
Result:=s;
|
||||
if IsASCII(Result) then begin
|
||||
// prevent codepage conversion magic
|
||||
SetCodePage(RawByteString(Result), CP_ACP, False);
|
||||
exit;
|
||||
end;
|
||||
UTF16WordCnt:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, Pointer(s), length(s), nil, 0);
|
||||
// this will null-terminate
|
||||
if UTF16WordCnt>0 then
|
||||
begin
|
||||
setlength(UTF16Str, UTF16WordCnt);
|
||||
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, Pointer(s), length(s), @UTF16Str[1], UTF16WordCnt);
|
||||
Result:=UTF16ToUTF8(UTF16Str);
|
||||
end;
|
||||
end;
|
||||
{$endif not wince}
|
||||
|
||||
{$ifdef WinCe}
|
||||
function UTF8ToConsole(const s: string): string; // converts UTF8 to console string (used by Write, WriteLn)
|
||||
begin
|
||||
Result := UTF8ToSystemCP(s);
|
||||
end;
|
||||
{$else}
|
||||
function UTF8ToConsole(const s: string): string; // converts UTF8 to console string (used by Write, WriteLn)
|
||||
var
|
||||
Dst: PChar;
|
||||
begin
|
||||
{$ifndef NO_CP_RTL}
|
||||
Result := UTF8ToSystemCP(s);
|
||||
{$else NO_CP_RTL}
|
||||
Result := s; // Kept for compatibility
|
||||
{$endif NO_CP_RTL}
|
||||
Dst := AllocMem((Length(Result) + 1) * SizeOf(Char));
|
||||
if CharToOEM(PChar(Result), Dst) then
|
||||
Result := StrPas(Dst);
|
||||
FreeMem(Dst);
|
||||
{$ifndef NO_CP_RTL}
|
||||
SetCodePage(RawByteString(Result), CP_OEMCP, False);
|
||||
{$endif NO_CP_RTL}
|
||||
end;
|
||||
{$endif not WinCE}
|
||||
|
||||
{$ifdef WinCE}
|
||||
function ConsoleToUTF8(const s: string): string;// converts console encoding to UTF8
|
||||
begin
|
||||
Result := SysToUTF8(s);
|
||||
end;
|
||||
{$else}
|
||||
function ConsoleToUTF8(const s: string): string;// converts console encoding to UTF8
|
||||
var
|
||||
Dst: PChar;
|
||||
begin
|
||||
Dst := AllocMem((Length(s) + 1) * SizeOf(Char));
|
||||
if OemToChar(PChar(s), Dst) then
|
||||
Result := StrPas(Dst)
|
||||
else
|
||||
Result := s;
|
||||
FreeMem(Dst);
|
||||
Result := SystemCPToUTF8(Result);
|
||||
end;
|
||||
{$endif not wince}
|
||||
|
||||
procedure InitPlatform;
|
||||
begin
|
||||
{$ifndef WinCE}
|
||||
if Win32MajorVersion <= 4 then
|
||||
begin
|
||||
{$IFDEF OldStuff}
|
||||
_ParamStrUtf8 := @ParamStrUtf8Ansi;
|
||||
{$ENDIF}
|
||||
end
|
||||
else
|
||||
{$endif}
|
||||
begin
|
||||
ArgsWCount := -1;
|
||||
{$IFDEF OldStuff}
|
||||
_ParamStrUtf8 := @ParamStrUtf8Wide;
|
||||
{$ENDIF}
|
||||
SetupCommandlineParametersWide;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure FinalizePlatform;
|
||||
{$IFDEF ArgsWAsUTF8}
|
||||
var
|
||||
p: PPChar;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF ArgsWAsUTF8}
|
||||
// restore argv and free memory
|
||||
if OldArgV<>nil then
|
||||
begin
|
||||
p:=argv;
|
||||
argv:=OldArgV;
|
||||
Freemem(p);
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
723
utils/pas2js/pas2jslogger.pp
Normal file
723
utils/pas2js/pas2jslogger.pp
Normal file
@ -0,0 +1,723 @@
|
||||
{ Author: Mattias Gaertner 2017 mattias@freepascal.org
|
||||
|
||||
Abstract:
|
||||
Logging to stdout or file.
|
||||
Filtering messages by number and type.
|
||||
Registering messages with number, pattern and type (error, warning, note, etc).
|
||||
}
|
||||
unit Pas2jsLogger;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
{$inline on}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, PasTree, PScanner, jstree, jsbase, jswriter,
|
||||
Pas2jsFileUtils;
|
||||
|
||||
const
|
||||
ExitCodeErrorInternal = 1; // internal error
|
||||
ExitCodeErrorInParams = 2; // error in command line parameters
|
||||
ExitCodeErrorInConfig = 3; // error in config file
|
||||
ExitCodeFileNotFound = 4;
|
||||
ExitCodeWriteError = 5;
|
||||
ExitCodeSyntaxError = 6;
|
||||
ExitCodeConverterError = 7;
|
||||
|
||||
const
|
||||
DefaultLogMsgTypes = [mtFatal..mtDebug]; // by default show everything
|
||||
|
||||
type
|
||||
|
||||
{ TPas2jsMessage }
|
||||
|
||||
TPas2jsMessage = class
|
||||
public
|
||||
Number: integer;
|
||||
Typ: TMessageType;
|
||||
Pattern: string;
|
||||
end;
|
||||
|
||||
TPas2jsLogEvent = Procedure (Sender : TObject; Const Msg : String) Of Object;
|
||||
|
||||
{ TPas2jsLogger }
|
||||
|
||||
TPas2jsLogger = class
|
||||
private
|
||||
FEncoding: string;
|
||||
FMsgNumberDisabled: PInteger;// sorted ascending
|
||||
FMsgNumberDisabledCount: integer;
|
||||
FMsg: TFPList; // list of TPas2jsMessage
|
||||
FOnFormatPath: TPScannerFormatPathEvent;
|
||||
FOnLog: TPas2jsLogEvent;
|
||||
FOutputFile: TFileWriter;
|
||||
FOutputFilename: string;
|
||||
FShowMsgNumbers: boolean;
|
||||
FShowMsgTypes: TMessageTypes;
|
||||
FSorted: boolean;
|
||||
function GetMsgCount: integer;
|
||||
function GetMsgNumberDisabled(MsgNumber: integer): boolean;
|
||||
function GetMsgs(Index: integer): TPas2jsMessage; inline;
|
||||
function FindMsgNumberDisabled(MsgNumber: integer; FindInsertPos: boolean): integer;
|
||||
procedure SetEncoding(const AValue: string);
|
||||
procedure SetMsgNumberDisabled(MsgNumber: integer; AValue: boolean);
|
||||
procedure SetOutputFilename(AValue: string);
|
||||
procedure SetSorted(AValue: boolean);
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
procedure RegisterMsg(MsgType: TMessageType; MsgNumber: integer; Pattern: string);
|
||||
function FindMsg(MsgNumber: integer; ExceptionOnNotFound: boolean): TPas2jsMessage;
|
||||
procedure Sort;
|
||||
procedure LogRaw(const Msg: string); overload;
|
||||
procedure LogRaw(Args: array of const); overload;
|
||||
procedure LogLn;
|
||||
procedure LogMsg(MsgNumber: integer; Args: array of const;
|
||||
const Filename: string = ''; Line: integer = 0; Col: integer = 0;
|
||||
UseFilter: boolean = true);
|
||||
procedure LogMsgIgnoreFilter(MsgNumber: integer; Args: array of const);
|
||||
function MsgTypeToStr(MsgType: TMessageType): string;
|
||||
procedure Log(MsgType: TMessageType; Msg: string; MsgNumber: integer = 0;
|
||||
const Filename: string = ''; Line: integer = 0; Col: integer = 0;
|
||||
UseFilter: boolean = true);
|
||||
function GetMsgText(MsgNumber: integer; Args: array of const): string;
|
||||
function FormatMsg(MsgType: TMessageType; Msg: string; MsgNumber: integer = 0;
|
||||
const Filename: string = ''; Line: integer = 0; Col: integer = 0): string;
|
||||
procedure OpenOutputFile;
|
||||
procedure Flush;
|
||||
procedure CloseOutputFile;
|
||||
procedure Reset;
|
||||
public
|
||||
property Encoding: string read FEncoding write SetEncoding; // normalized
|
||||
property MsgCount: integer read GetMsgCount;
|
||||
property Msgs[Index: integer]: TPas2jsMessage read GetMsgs;
|
||||
property MsgNumberDisabled[MsgNumber: integer]: boolean read GetMsgNumberDisabled write SetMsgNumberDisabled;
|
||||
property OnFormatPath: TPScannerFormatPathEvent read FOnFormatPath write FOnFormatPath;
|
||||
property OutputFilename: string read FOutputFilename write SetOutputFilename;
|
||||
property ShowMsgNumbers: boolean read FShowMsgNumbers write FShowMsgNumbers;
|
||||
property ShowMsgTypes: TMessageTypes read FShowMsgTypes write FShowMsgTypes;
|
||||
property Sorted: boolean read FSorted write SetSorted;
|
||||
Property OnLog : TPas2jsLogEvent Read FOnLog Write FonLog;
|
||||
end;
|
||||
|
||||
function CompareP2JMessage(Item1, Item2: Pointer): Integer;
|
||||
|
||||
function AsString(Element: TPasElement; Full: boolean = true): string; overload;
|
||||
function AsString(Element: TJSElement): string; overload;
|
||||
function DbgString(Element: TJSElement; Indent: integer): string; overload;
|
||||
function DbgAsString(Element: TJSValue; Indent: integer): string; overload;
|
||||
function DbgAsString(Element: TJSArrayLiteralElements; Indent: integer): string; overload;
|
||||
function DbgAsString(Element: TJSObjectLiteralElements; Indent: integer): string; overload;
|
||||
function DbgAsString(Element: TJSObjectLiteralElement; Indent: integer): string; overload;
|
||||
function DbgHexMem(p: Pointer; Count: integer): string;
|
||||
function DbgStr(const s: string): string;
|
||||
|
||||
implementation
|
||||
|
||||
function CompareP2JMessage(Item1, Item2: Pointer): Integer;
|
||||
var
|
||||
Msg1: TPas2jsMessage absolute Item1;
|
||||
Msg2: TPas2jsMessage absolute Item2;
|
||||
begin
|
||||
Result:=Msg1.Number-Msg2.Number;
|
||||
end;
|
||||
|
||||
function AsString(Element: TPasElement; Full: boolean): string;
|
||||
begin
|
||||
if Element=nil then
|
||||
Result:='(no element)'
|
||||
else begin
|
||||
Result:=Element.GetDeclaration(Full);
|
||||
end;
|
||||
end;
|
||||
|
||||
function AsString(Element: TJSElement): string;
|
||||
var
|
||||
aTextWriter: TBufferWriter;
|
||||
aWriter: TJSWriter;
|
||||
begin
|
||||
aTextWriter:=TBufferWriter.Create(120);
|
||||
aWriter:=TJSWriter.Create(aTextWriter);
|
||||
aWriter.WriteJS(Element);
|
||||
Result:=aTextWriter.AsAnsistring;
|
||||
aWriter.Free;
|
||||
aTextWriter.Free;
|
||||
end;
|
||||
|
||||
function DbgString(Element: TJSElement; Indent: integer): string;
|
||||
begin
|
||||
if Element=nil then
|
||||
Result:='(*no element*)'
|
||||
else if Element is TJSLiteral then begin
|
||||
Result:=DbgAsString(TJSLiteral(Element).Value,Indent+2);
|
||||
end else if Element is TJSPrimaryExpressionIdent then begin
|
||||
Result:=String(TJSPrimaryExpressionIdent(Element).Name);
|
||||
|
||||
// array literal
|
||||
end else if Element is TJSArrayLiteral then begin
|
||||
Result:='['+DbgAsString(TJSArrayLiteral(Element).Elements,Indent+2)+']';
|
||||
|
||||
// object literal
|
||||
end else if Element is TJSObjectLiteral then begin
|
||||
Result:='['+DbgAsString(TJSObjectLiteral(Element).Elements,Indent+2)+']';
|
||||
|
||||
// arguments
|
||||
end else if Element is TJSArguments then begin
|
||||
Result:='('+DbgAsString(TJSArguments(Element).Elements,Indent+2)+')';
|
||||
|
||||
// member
|
||||
end else if Element is TJSMemberExpression then begin
|
||||
Result:='('+DbgString(TJSMemberExpression(Element).MExpr,Indent+2)+')';
|
||||
// ToDo: TJSNewMemberExpression
|
||||
// ToDo: TJSDotMemberExpression
|
||||
// ToDo: TJSBracketMemberExpression
|
||||
|
||||
// call
|
||||
end else if Element is TJSCallExpression then begin
|
||||
Result:=DbgString(TJSCallExpression(Element).Expr,Indent+2)
|
||||
+DbgString(TJSCallExpression(Element).Args,Indent+2);
|
||||
|
||||
// unary
|
||||
end else if Element is TJSUnary then begin
|
||||
Result:=TJSUnary(Element).PrefixOperator
|
||||
+DbgString(TJSUnary(Element).A,Indent+2)
|
||||
+TJSUnary(Element).PostFixOperator;
|
||||
|
||||
// binary
|
||||
end else if Element is TJSBinary then begin
|
||||
if Element is TJSStatementList then begin
|
||||
Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2)+';'+LineEnding
|
||||
+Space(Indent)+DbgString(TJSBinaryExpression(Element).B,Indent);
|
||||
end else if Element is TJSVariableDeclarationList then begin
|
||||
Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2)+';'+LineEnding
|
||||
+Space(Indent)+DbgString(TJSBinaryExpression(Element).B,Indent);
|
||||
end else if Element is TJSWithStatement then begin
|
||||
Result:='with ('+DbgString(TJSBinaryExpression(Element).A,Indent+2)+'){'+LineEnding
|
||||
+Space(Indent)+DbgString(TJSBinaryExpression(Element).B,Indent+2)+LineEnding
|
||||
+Space(Indent)+'}';
|
||||
end else if Element is TJSBinaryExpression then begin
|
||||
Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2);
|
||||
if TJSBinaryExpression(Element).AllowCompact then
|
||||
Result+=TJSBinaryExpression(Element).OperatorString
|
||||
else
|
||||
Result+=' '+TJSBinaryExpression(Element).OperatorString+' ';
|
||||
Result+=DbgString(TJSBinaryExpression(Element).B,Indent+2);
|
||||
end else begin
|
||||
Result:='{: unknown binary Element: '+Element.Classname+':}';
|
||||
end;
|
||||
|
||||
// ? :
|
||||
end else if Element is TJSConditionalExpression then begin
|
||||
Result:=DbgString(TJSConditionalExpression(Element).A,Indent+2)
|
||||
+'?'+DbgString(TJSConditionalExpression(Element).B,Indent+2)
|
||||
+':'+DbgString(TJSConditionalExpression(Element).C,Indent+2);
|
||||
|
||||
// assignment
|
||||
end else if Element is TJSAssignStatement then begin
|
||||
Result:=DbgString(TJSAssignStatement(Element).LHS,Indent+2)
|
||||
+TJSAssignStatement(Element).OperatorString
|
||||
+DbgString(TJSAssignStatement(Element).Expr,Indent+2);
|
||||
|
||||
// var
|
||||
end else if Element is TJSVarDeclaration then begin
|
||||
Result:=TJSVarDeclaration(Element).Name;
|
||||
if TJSVarDeclaration(Element).Init<>nil then
|
||||
Result+='='+DbgString(TJSVarDeclaration(Element).Init,Indent+2);
|
||||
|
||||
// if(){} else {}
|
||||
end else if Element is TJSIfStatement then begin
|
||||
Result:='if('+DbgString(TJSIfStatement(Element).Cond,Indent+2)+'){'+LineEnding
|
||||
+Space(Indent+2)+DbgString(TJSIfStatement(Element).BTrue,Indent+2)+LineEnding
|
||||
+Space(Indent);
|
||||
if TJSIfStatement(Element).BFalse<>nil then
|
||||
Result+=' else {'+LineEnding
|
||||
+Space(Indent+2)+DbgString(TJSIfStatement(Element).BFalse,Indent+2)+LineEnding
|
||||
+Space(Indent)+'}';
|
||||
|
||||
// body
|
||||
end else if Element is TJSBodyStatement then begin
|
||||
|
||||
// while(){}
|
||||
if Element is TJSWhileStatement then begin
|
||||
Result:='while('+DbgString(TJSWhileStatement(Element).Cond,Indent+2)+')';
|
||||
if TJSWhileStatement(Element).Body<>nil then
|
||||
Result+=DbgString(TJSWhileStatement(Element).Body,Indent)
|
||||
else
|
||||
Result+='{}';
|
||||
|
||||
// do{}while()
|
||||
end else if Element is TJSDoWhileStatement then begin
|
||||
Result:='do';
|
||||
if TJSDoWhileStatement(Element).Body<>nil then
|
||||
Result+=DbgString(TJSDoWhileStatement(Element).Body,Indent)
|
||||
else
|
||||
Result+='{}';
|
||||
Result+='('+DbgString(TJSDoWhileStatement(Element).Cond,Indent+2)+')';
|
||||
|
||||
// for(Init;Incr;Cond)Body
|
||||
end else if Element is TJSForStatement then begin
|
||||
Result:='for(';
|
||||
if TJSForStatement(Element).Init<>nil then
|
||||
Result+=DbgString(TJSForStatement(Element).Init,Indent+2);
|
||||
Result+=';';
|
||||
if TJSForStatement(Element).Cond<>nil then
|
||||
Result+=DbgString(TJSForStatement(Element).Cond,Indent+2);
|
||||
Result+=';';
|
||||
if TJSForStatement(Element).Incr<>nil then
|
||||
Result+=DbgString(TJSForStatement(Element).Incr,Indent+2);
|
||||
Result+=')';
|
||||
if TJSForStatement(Element).Body<>nil then
|
||||
Result+=DbgString(TJSForStatement(Element).Body,Indent)
|
||||
else
|
||||
Result+='{}';
|
||||
|
||||
// {}
|
||||
end else begin
|
||||
if TJSBodyStatement(Element).Body<>nil then
|
||||
Result+='{'+LineEnding
|
||||
+Space(Indent+2)+DbgString(TJSBodyStatement(Element).Body,Indent+2)+LineEnding
|
||||
+Space(Indent)+'}'
|
||||
else
|
||||
Result+='{}';
|
||||
end;
|
||||
|
||||
end else begin
|
||||
Result:='{: unknown Element: '+Element.Classname+':}';
|
||||
end;
|
||||
end;
|
||||
|
||||
function DbgAsString(Element: TJSValue; Indent: integer): string;
|
||||
begin
|
||||
if Element=nil then
|
||||
Result:='(no value)'
|
||||
else begin
|
||||
case Element.ValueType of
|
||||
jstUNDEFINED: Result:='undefined';
|
||||
jstNull: Result:='null';
|
||||
jstBoolean: Result:=BoolToStr(Element.AsBoolean,'true','false');
|
||||
jstNumber: str(Element.AsNumber,Result);
|
||||
jstString: Result:=AnsiQuotedStr(Element.AsString{%H-},'''');
|
||||
jstObject: Result:='{:OBJECT:}';
|
||||
jstReference: Result:='{:REFERENCE:}';
|
||||
JSTCompletion: Result:='{:COMPLETION:}';
|
||||
else Result:='{:Unknown ValueType '+IntToStr(ord(Element.ValueType))+':}';
|
||||
end;
|
||||
end;
|
||||
Result:=Space(Indent)+Result;
|
||||
end;
|
||||
|
||||
function DbgAsString(Element: TJSArrayLiteralElements; Indent: integer): string;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
Result:='';
|
||||
for i:=0 to TJSArrayLiteralElements(Element).Count-1 do begin
|
||||
if i>0 then Result+=',';
|
||||
Result+=DbgString(TJSArrayLiteralElements(Element).Elements[i].Expr,Indent+2);
|
||||
end;
|
||||
end;
|
||||
|
||||
function DbgAsString(Element: TJSObjectLiteralElements; Indent: integer): string;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
Result:='';
|
||||
for i:=0 to TJSObjectLiteralElements(Element).Count-1 do begin
|
||||
if i>0 then Result+=',';
|
||||
Result+=DbgString(TJSObjectLiteralElements(Element).Elements[i].Expr,Indent+2);
|
||||
end;
|
||||
end;
|
||||
|
||||
function DbgAsString(Element: TJSObjectLiteralElement; Indent: integer): string;
|
||||
begin
|
||||
Result:=String(TJSObjectLiteralElement(Element).Name)
|
||||
+':'+DbgString(TJSObjectLiteralElement(Element).Expr,Indent+2);
|
||||
end;
|
||||
|
||||
function DbgHexMem(p: Pointer; Count: integer): string;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
Result:='';
|
||||
for i:=0 to Count-1 do
|
||||
Result:=Result+HexStr(ord(PChar(p)[i]),2);
|
||||
end;
|
||||
|
||||
function DbgStr(const s: string): string;
|
||||
var
|
||||
i: Integer;
|
||||
c: Char;
|
||||
begin
|
||||
Result:='';
|
||||
for i:=1 to length(s) do begin
|
||||
c:=s[i];
|
||||
case c of
|
||||
#0..#31,#127..#255: Result+='$'+HexStr(ord(c),2);
|
||||
else Result+=c;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TPas2jsLogger }
|
||||
|
||||
function TPas2jsLogger.GetMsgs(Index: integer): TPas2jsMessage;
|
||||
begin
|
||||
Result:=TPas2jsMessage(FMsg[Index]);
|
||||
end;
|
||||
|
||||
function TPas2jsLogger.FindMsgNumberDisabled(MsgNumber: integer;
|
||||
FindInsertPos: boolean): integer;
|
||||
var
|
||||
l, r, m, CurMsgNumber: Integer;
|
||||
begin
|
||||
l:=0;
|
||||
r:=FMsgNumberDisabledCount-1;
|
||||
m:=0;
|
||||
while l<=r do begin
|
||||
m:=(l+r) div 2;
|
||||
CurMsgNumber:=FMsgNumberDisabled[m];
|
||||
if MsgNumber<CurMsgNumber then
|
||||
r:=m-1
|
||||
else if MsgNumber>CurMsgNumber then
|
||||
l:=m+1
|
||||
else
|
||||
exit(m);
|
||||
end;
|
||||
if FindInsertPos then begin
|
||||
Result:=m;
|
||||
if l>m then inc(Result);
|
||||
end else begin
|
||||
Result:=-1;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.SetEncoding(const AValue: string);
|
||||
var
|
||||
NewValue: String;
|
||||
begin
|
||||
NewValue:=NormalizeEncoding(AValue);
|
||||
if FEncoding=NewValue then Exit;
|
||||
//LogRaw(ClassName+': Encoding changed from "'+FEncoding+'" to "'+NewValue+'"');
|
||||
FEncoding:=NewValue;
|
||||
end;
|
||||
|
||||
function TPas2jsLogger.GetMsgNumberDisabled(MsgNumber: integer): boolean;
|
||||
begin
|
||||
Result:=FindMsgNumberDisabled(MsgNumber,false)>=0;
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.SetMsgNumberDisabled(MsgNumber: integer; AValue: boolean
|
||||
);
|
||||
var
|
||||
InsertPos, OldCount: Integer;
|
||||
begin
|
||||
OldCount:=FMsgNumberDisabledCount;
|
||||
if AValue then begin
|
||||
// enable
|
||||
InsertPos:=FindMsgNumberDisabled(MsgNumber,true);
|
||||
if (InsertPos<OldCount) and (FMsgNumberDisabled[InsertPos]=MsgNumber) then
|
||||
exit; // already disabled
|
||||
inc(FMsgNumberDisabledCount);
|
||||
ReAllocMem(FMsgNumberDisabled,SizeOf(Integer)*FMsgNumberDisabledCount);
|
||||
if InsertPos<OldCount then
|
||||
Move(FMsgNumberDisabled[InsertPos],FMsgNumberDisabled[InsertPos+1],
|
||||
SizeOf(Integer)*(OldCount-InsertPos));
|
||||
FMsgNumberDisabled[InsertPos]:=MsgNumber;
|
||||
end else begin
|
||||
// disable
|
||||
InsertPos:=FindMsgNumberDisabled(MsgNumber,false);
|
||||
if InsertPos<0 then exit;
|
||||
if InsertPos+1<OldCount then
|
||||
Move(FMsgNumberDisabled[InsertPos+1],FMsgNumberDisabled[InsertPos],
|
||||
SizeOf(Integer)*(OldCount-InsertPos-1));
|
||||
dec(FMsgNumberDisabledCount);
|
||||
ReAllocMem(FMsgNumberDisabled,SizeOf(Integer)*FMsgNumberDisabledCount);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.SetOutputFilename(AValue: string);
|
||||
begin
|
||||
if FOutputFilename=AValue then Exit;
|
||||
CloseOutputFile;
|
||||
FOutputFilename:=AValue;
|
||||
if OutputFilename<>'' then
|
||||
OpenOutputFile;
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.SetSorted(AValue: boolean);
|
||||
begin
|
||||
if FSorted=AValue then Exit;
|
||||
FSorted:=AValue;
|
||||
if FSorted then Sort;
|
||||
end;
|
||||
|
||||
constructor TPas2jsLogger.Create;
|
||||
begin
|
||||
FMsg:=TFPList.Create;
|
||||
FShowMsgTypes:=DefaultLogMsgTypes;
|
||||
end;
|
||||
|
||||
destructor TPas2jsLogger.Destroy;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
CloseOutputFile;
|
||||
for i:=0 to FMsg.Count-1 do
|
||||
TObject(FMsg[i]).Free;
|
||||
FreeAndNil(FMsg);
|
||||
ReAllocMem(FMsgNumberDisabled,0);
|
||||
FMsgNumberDisabledCount:=0;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.RegisterMsg(MsgType: TMessageType; MsgNumber: integer;
|
||||
Pattern: string);
|
||||
var
|
||||
Msg: TPas2jsMessage;
|
||||
begin
|
||||
if MsgNumber=0 then
|
||||
raise Exception.Create('internal error: TPas2jsLogger.RegisterMsg MsgNumber=0');
|
||||
Msg:=TPas2jsMessage.Create;
|
||||
Msg.Number:=MsgNumber;
|
||||
Msg.Typ:=MsgType;
|
||||
Msg.Pattern:=Pattern;
|
||||
FMsg.Add(Msg);
|
||||
FSorted:=false;
|
||||
end;
|
||||
|
||||
function TPas2jsLogger.GetMsgCount: integer;
|
||||
begin
|
||||
Result:=FMsg.Count;
|
||||
end;
|
||||
|
||||
function TPas2jsLogger.FindMsg(MsgNumber: integer; ExceptionOnNotFound: boolean
|
||||
): TPas2jsMessage;
|
||||
var
|
||||
l, r, m: Integer;
|
||||
Msg: TPas2jsMessage;
|
||||
begin
|
||||
if not FSorted then Sort;
|
||||
l:=0;
|
||||
r:=GetMsgCount-1;
|
||||
while l<=r do begin
|
||||
m:=(l+r) div 2;
|
||||
Msg:=Msgs[m];
|
||||
if MsgNumber<Msg.Number then
|
||||
r:=m-1
|
||||
else if MsgNumber>Msg.Number then
|
||||
l:=m+1
|
||||
else
|
||||
exit(Msg);
|
||||
end;
|
||||
Result:=nil;
|
||||
if ExceptionOnNotFound then
|
||||
raise Exception.Create('invalid message number '+IntToStr(MsgNumber));
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.Sort;
|
||||
var
|
||||
i: Integer;
|
||||
LastMsg, CurMsg: TPas2jsMessage;
|
||||
begin
|
||||
if FMsg.Count>1 then begin;
|
||||
FMsg.Sort(@CompareP2JMessage);
|
||||
|
||||
// check for duplicates
|
||||
LastMsg:=TPas2jsMessage(FMsg[0]);
|
||||
for i:=1 to FMsg.Count-1 do begin
|
||||
CurMsg:=TPas2jsMessage(FMsg[i]);
|
||||
if LastMsg.Number=CurMsg.Number then
|
||||
raise Exception.Create('duplicate message number '+IntToStr(CurMsg.Number)+'. 1st="'+LastMsg.Pattern+'" 2nd="'+CurMsg.Pattern+'"');
|
||||
LastMsg:=CurMsg;
|
||||
end;
|
||||
end;
|
||||
FSorted:=true;
|
||||
end;
|
||||
|
||||
function TPas2jsLogger.GetMsgText(MsgNumber: integer;
|
||||
Args: array of const): string;
|
||||
var
|
||||
Msg: TPas2jsMessage;
|
||||
begin
|
||||
Msg:=FindMsg(MsgNumber,true);
|
||||
Result:=MsgTypeToStr(Msg.Typ)+': '+Format(Msg.Pattern,Args);
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.LogRaw(const Msg: string);
|
||||
var
|
||||
S: String;
|
||||
begin
|
||||
S:=Msg;
|
||||
if Encoding='utf8' then
|
||||
else if Encoding='console' then
|
||||
S:=UTF8ToConsole(S)
|
||||
else if Encoding='system' then
|
||||
S:=UTF8ToSystemCP(S)
|
||||
else begin
|
||||
// default: write UTF-8 to outputfile and console codepage to console
|
||||
if FOutputFile=nil then
|
||||
S:=UTF8ToConsole(S);
|
||||
end;
|
||||
//writeln('TPas2jsLogger.LogRaw "',Encoding,'" "',DbgStr(S),'"');
|
||||
if FOnLog<>Nil then
|
||||
FOnLog(Self,S)
|
||||
else if FOutputFile<>nil then
|
||||
FOutputFile.Write(S+LineEnding)
|
||||
else begin
|
||||
// prevent codepage conversion magic
|
||||
SetCodePage(RawByteString(S), CP_OEMCP, False);
|
||||
writeln(S);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.LogRaw(Args: array of const);
|
||||
var
|
||||
s: String;
|
||||
i: Integer;
|
||||
begin
|
||||
s:='';
|
||||
for i:=Low(Args) to High(Args) do
|
||||
begin
|
||||
case Args[i].VType of
|
||||
vtInteger: s += IntToStr(Args[i].VInteger);
|
||||
vtBoolean: s += BoolToStr(Args[i].VBoolean);
|
||||
vtChar: s += Args[i].VChar;
|
||||
{$ifndef FPUNONE}
|
||||
vtExtended: ; // Args[i].VExtended^;
|
||||
{$ENDIF}
|
||||
vtString: s += Args[i].VString^;
|
||||
vtPointer: ; // Args[i].VPointer;
|
||||
vtPChar: s += Args[i].VPChar;
|
||||
vtObject: ; // Args[i].VObject;
|
||||
vtClass: ; // Args[i].VClass;
|
||||
vtWideChar: s += AnsiString(Args[i].VWideChar);
|
||||
vtPWideChar: s += AnsiString(Args[i].VPWideChar);
|
||||
vtAnsiString: s += AnsiString(Args[i].VAnsiString);
|
||||
vtCurrency: ; // Args[i].VCurrency^);
|
||||
vtVariant: ; // Args[i].VVariant^);
|
||||
vtInterface: ; // Args[i].VInterface^);
|
||||
vtWidestring: s += AnsiString(WideString(Args[i].VWideString));
|
||||
vtInt64: s += IntToStr(Args[i].VInt64^);
|
||||
vtQWord: s += IntToStr(Args[i].VQWord^);
|
||||
vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString));
|
||||
end;
|
||||
end;
|
||||
LogRaw(s);
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.LogLn;
|
||||
begin
|
||||
LogRaw('');
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.LogMsg(MsgNumber: integer; Args: array of const;
|
||||
const Filename: string; Line: integer; Col: integer; UseFilter: boolean);
|
||||
var
|
||||
s: String;
|
||||
Msg: TPas2jsMessage;
|
||||
begin
|
||||
Msg:=FindMsg(MsgNumber,true);
|
||||
if UseFilter and not (Msg.Typ in FShowMsgTypes) then exit;
|
||||
if MsgNumberDisabled[MsgNumber] then exit;
|
||||
s:=FormatMsg(Msg.Typ,SafeFormat(Msg.Pattern,Args),MsgNumber,Filename,Line,Col);
|
||||
LogRaw(s);
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.LogMsgIgnoreFilter(MsgNumber: integer;
|
||||
Args: array of const);
|
||||
begin
|
||||
LogMsg(MsgNumber,Args,'',0,0,false);
|
||||
end;
|
||||
|
||||
function TPas2jsLogger.MsgTypeToStr(MsgType: TMessageType): string;
|
||||
begin
|
||||
case MsgType of
|
||||
mtFatal: Result:='Fatal';
|
||||
mtError: Result:='Error';
|
||||
mtWarning: Result:='Warning';
|
||||
mtNote: Result:='Note';
|
||||
mtHint: Result:='Hint';
|
||||
mtInfo: Result:='Info';
|
||||
mtDebug: Result:='Debug';
|
||||
else Result:='Verbose';
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.Log(MsgType: TMessageType; Msg: string;
|
||||
MsgNumber: integer; const Filename: string; Line: integer; Col: integer;
|
||||
UseFilter: boolean);
|
||||
var
|
||||
s: String;
|
||||
begin
|
||||
if UseFilter and not (MsgType in FShowMsgTypes) then exit;
|
||||
if MsgNumberDisabled[MsgNumber] then exit;
|
||||
s:=FormatMsg(MsgType,Msg,MsgNumber,Filename,Line,Col);
|
||||
LogRaw(s);
|
||||
end;
|
||||
|
||||
function TPas2jsLogger.FormatMsg(MsgType: TMessageType; Msg: string;
|
||||
MsgNumber: integer; const Filename: string; Line: integer; Col: integer
|
||||
): string;
|
||||
// e.g. file(line,col) type: (number) msg
|
||||
var
|
||||
s: String;
|
||||
begin
|
||||
s:='';
|
||||
if Filename<>'' then begin
|
||||
if Assigned(OnFormatPath) then
|
||||
s+=OnFormatPath(Filename)
|
||||
else
|
||||
s+=Filename;
|
||||
if Line>0 then begin
|
||||
s+='('+IntToStr(Line);
|
||||
if Col>0 then s+=','+IntToStr(Col);
|
||||
s+=')';
|
||||
end;
|
||||
if s<>'' then s+=' ';
|
||||
end;
|
||||
s+=MsgTypeToStr(MsgType)+': ';
|
||||
if ShowMsgNumbers and (MsgNumber<>0) then
|
||||
s+='('+IntToStr(MsgNumber)+') ';
|
||||
s+=Msg;
|
||||
Result:=s;
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.OpenOutputFile;
|
||||
begin
|
||||
if FOutputFile<>nil then exit;
|
||||
if OutputFilename='' then
|
||||
raise Exception.Create('Log has empty OutputFilename');
|
||||
if DirectoryExists(OutputFilename) then
|
||||
raise Exception.Create('Log is directory: "'+OutputFilename+'"');
|
||||
FOutputFile:=TFileWriter.Create(OutputFilename);
|
||||
if (Encoding='') or (Encoding='utf8') then
|
||||
FOutputFile.Write(UTF8BOM);
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.Flush;
|
||||
begin
|
||||
if FOutputFile<>nil then
|
||||
FOutputFile.Flush;
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.CloseOutputFile;
|
||||
begin
|
||||
if FOutputFile=nil then exit;
|
||||
FOutputFile.Flush;
|
||||
FreeAndNil(FOutputFile);
|
||||
end;
|
||||
|
||||
procedure TPas2jsLogger.Reset;
|
||||
begin
|
||||
OutputFilename:='';
|
||||
if FMsgNumberDisabled<>nil then begin
|
||||
ReAllocMem(FMsgNumberDisabled,0);
|
||||
FMsgNumberDisabledCount:=0;
|
||||
end;
|
||||
ShowMsgNumbers:=false;
|
||||
FShowMsgTypes:=DefaultLogMsgTypes;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
157
utils/pas2js/pas2jspparser.pp
Normal file
157
utils/pas2js/pas2jspparser.pp
Normal file
@ -0,0 +1,157 @@
|
||||
{ Author: Mattias Gaertner 2017 mattias@freepascal.org
|
||||
|
||||
Abstract:
|
||||
Extends the FCL Pascal parser for the language subset of pas2js.
|
||||
}
|
||||
unit Pas2jsPParser;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
{$inline on}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, PParser, PScanner, PasTree, PasResolver, fppas2js,
|
||||
Pas2jsLogger;
|
||||
|
||||
const // Messages
|
||||
nFinalizationNotSupported = 3001;
|
||||
sFinalizationNotSupported = 'Finalization section is not supported.';
|
||||
|
||||
type
|
||||
|
||||
{ TPas2jsPasParser }
|
||||
|
||||
TPas2jsPasParser = class(TPasParser)
|
||||
private
|
||||
FLog: TPas2jsLogger;
|
||||
public
|
||||
constructor Create(AScanner: TPascalScanner;
|
||||
AFileResolver: TBaseFileResolver; AEngine: TPasTreeContainer);
|
||||
procedure SetLastMsg(MsgType: TMessageType; MsgNumber: integer;
|
||||
Const Fmt : String; Args : Array of const);
|
||||
procedure RaiseParserError(MsgNumber: integer; Args: array of const);
|
||||
procedure ParseSubModule(var Module: TPasModule);
|
||||
property Log: TPas2jsLogger read FLog write FLog;
|
||||
end;
|
||||
|
||||
TOnFindModule = function(const aUnitname: String): TPasModule of object;
|
||||
TOnCheckSrcName = procedure(const aElement: TPasElement) of object;
|
||||
|
||||
{ TPas2jsCompilerResolver }
|
||||
|
||||
TPas2jsCompilerResolver = class(TPas2JSResolver)
|
||||
private
|
||||
FLog: TPas2jsLogger;
|
||||
FOnCheckSrcName: TOnCheckSrcName;
|
||||
FOnContinueParsing: TNotifyEvent;
|
||||
FOnFindModule: TOnFindModule;
|
||||
FP2JParser: TPas2jsPasParser;
|
||||
public
|
||||
function CreateElement(AClass: TPTreeElement; const AName: String;
|
||||
AParent: TPasElement; AVisibility: TPasMemberVisibility;
|
||||
const ASrcPos: TPasSourcePos): TPasElement;
|
||||
overload; override;
|
||||
function FindModule(const aUnitname: String): TPasModule; override;
|
||||
procedure ContinueParsing; override;
|
||||
public
|
||||
Owner: TObject;
|
||||
property OnContinueParsing: TNotifyEvent read FOnContinueParsing write FOnContinueParsing;
|
||||
property OnFindModule: TOnFindModule read FOnFindModule write FOnFindModule;
|
||||
property OnCheckSrcName: TOnCheckSrcName read FOnCheckSrcName write FOnCheckSrcName;
|
||||
property Log: TPas2jsLogger read FLog write FLog;
|
||||
property P2JParser: TPas2jsPasParser read FP2JParser write FP2JParser;
|
||||
end;
|
||||
|
||||
procedure RegisterMessages(Log: TPas2jsLogger);
|
||||
|
||||
implementation
|
||||
|
||||
procedure RegisterMessages(Log: TPas2jsLogger);
|
||||
var
|
||||
LastMsgNumber: integer;
|
||||
|
||||
procedure r(MsgType: TMessageType; MsgNumber: integer; const MsgPattern: string);
|
||||
var
|
||||
s: String;
|
||||
begin
|
||||
if (LastMsgNumber>=0) and (MsgNumber<>LastMsgNumber+1) then
|
||||
begin
|
||||
s:='gap in registered message numbers: '+IntToStr(LastMsgNumber)+' '+IntToStr(MsgNumber);
|
||||
writeln('Pas2jsPParser.RegisterMessages ',s);
|
||||
raise Exception.Create(s);
|
||||
end;
|
||||
Log.RegisterMsg(MsgType,MsgNumber,MsgPattern);
|
||||
LastMsgNumber:=MsgNumber;
|
||||
end;
|
||||
|
||||
begin
|
||||
LastMsgNumber:=-1;
|
||||
r(mtError,nFinalizationNotSupported,sFinalizationNotSupported);
|
||||
end;
|
||||
|
||||
{ TPas2jsPasParser }
|
||||
|
||||
constructor TPas2jsPasParser.Create(AScanner: TPascalScanner;
|
||||
AFileResolver: TBaseFileResolver; AEngine: TPasTreeContainer);
|
||||
begin
|
||||
inherited Create(AScanner,AFileResolver,AEngine);
|
||||
Options:=Options+[po_asmwhole,po_resolvestandardtypes];
|
||||
end;
|
||||
|
||||
procedure TPas2jsPasParser.SetLastMsg(MsgType: TMessageType;
|
||||
MsgNumber: integer; const Fmt: String; Args: array of const);
|
||||
begin
|
||||
inherited SetLastMsg(MsgType,MsgNumber,Fmt,Args);
|
||||
end;
|
||||
|
||||
procedure TPas2jsPasParser.RaiseParserError(MsgNumber: integer; Args: array of const);
|
||||
var
|
||||
Msg: TPas2jsMessage;
|
||||
begin
|
||||
Msg:=Log.FindMsg(MsgNumber,true);
|
||||
SetLastMsg(Msg.Typ,MsgNumber,Msg.Pattern,Args);
|
||||
raise EParserError.Create(LastMsg,Scanner.CurFilename,
|
||||
Scanner.CurRow,Scanner.CurColumn);
|
||||
end;
|
||||
|
||||
procedure TPas2jsPasParser.ParseSubModule(var Module: TPasModule);
|
||||
begin
|
||||
Module:=nil;
|
||||
NextToken;
|
||||
SaveComments;
|
||||
case CurToken of
|
||||
tkUnit:
|
||||
ParseUnit(Module);
|
||||
tkLibrary:
|
||||
ParseLibrary(Module);
|
||||
else
|
||||
ExpectToken(tkUnit);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TPas2jsCompilerResolver }
|
||||
|
||||
function TPas2jsCompilerResolver.CreateElement(AClass: TPTreeElement;
|
||||
const AName: String; AParent: TPasElement; AVisibility: TPasMemberVisibility;
|
||||
const ASrcPos: TPasSourcePos): TPasElement;
|
||||
begin
|
||||
if AClass=TFinalizationSection then
|
||||
(CurrentParser as TPas2jsPasParser).RaiseParserError(nFinalizationNotSupported,[]);
|
||||
Result:=inherited;
|
||||
if (Result is TPasModule) then
|
||||
OnCheckSrcName(Result);
|
||||
end;
|
||||
|
||||
function TPas2jsCompilerResolver.FindModule(const aUnitname: String): TPasModule;
|
||||
begin
|
||||
Result:=OnFindModule(aUnitname);
|
||||
end;
|
||||
|
||||
procedure TPas2jsCompilerResolver.ContinueParsing;
|
||||
begin
|
||||
OnContinueParsing(Self);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user