2012年5月23日
在SOA的基础技术实现方式中WebService占据了很重要的地位，通常我们提到WebService第一想法就是SOAP消息在各种传输协议上交互。近几年REST的思想伴随着SOA逐渐被大家接受，同时各大网站不断开放API提供给开发者，也激起了REST风格WebService的热潮。
在收到新需求Email之前，我对REST的理解仅仅是通过半懂不懂的看了Fielding的REST博士论文，说实话当时也就是希望了解这么一个新概念，对于其内部的思想只是很肤浅的了解了一下。
ASF的最新需求就是可能需要实现REST风格的WebService集成，因此不得不好好的去看看REST的真正思想含义以及当前各大网站的设计方式。后面所要表述的也是我这个初学者的一些看法和观点，抛砖引玉，希望在我将REST融入到ASF之前能够获得更多的反馈和意见。
SOAP
什么是SOAP，我想不用多说，google一把满眼都是。其实SOAP最早是针对RPC的一种解决方案，简单对象访问协议，很轻量，同时作为应用协议可以基于多种传输协议来传递消息（Http,SMTP等）。但是随着SOAP作为WebService的广泛应用，不断地增加附加的内容，使得现在开发人员觉得SOAP很重，使用门槛很高。在SOAP后续的发展过程中，WS-*一系列协议的制定，增加了SOAP的成熟度，也给SOAP增加了负担。
REST
REST其实并不是什么协议也不是什么标准，而是将Http协议的设计初衷作了诠释，在Http协议被广泛利用的今天，越来越多的是将其作为传输协议，而非原先设计者所考虑的应用协议。SOAP类型的WebService就是最好的例子，SOAP消息完全就是将Http协议作为消息承载，以至于对于Http协议中的各种参数（例如编码，错误码等）都置之不顾。其实，最轻量级的应用协议就是Http协议。Http协议所抽象的get,post,put,delete就好比数据库中最基本的增删改查，而互联网上的各种资源就好比数据库中的记录（可能这么比喻不是很好），对于各种资源的操作最后总是能抽象成为这四种基本操作，在定义了定位资源的规则以后，对于资源的操作通过标准的Http协议就可以实现，开发者也会受益于这种轻量级的协议。
自己理解的将REST的思想归结以下有如下几个关键点：
1．面向资源的接口设计
所有的接口设计都是针对资源来设计的，也就很类似于我们的面向对象和面向过程的设计区别，只不过现在将网络上的操作实体都作为资源来看待，同时URI的设计也是体现了对于资源的定位设计。后面会提到有一些网站的API设计说是REST设计，其实是RPC-REST的混合体，并非是REST的思想。
2．抽象操作为基础的CRUD
这点很简单，Http中的get,put,post,delete分别对应了read,update,create,delete四种操作，如果仅仅是作为对于资源的操作，抽象成为这四种已经足够了，但是对于现在的一些复杂的业务服务接口设计，可能这样的抽象未必能够满足。其实这也在后面的几个网站的API设计中暴露了这样的问题，如果要完全按照REST的思想来设计，那么适用的环境将会有限制，而非放之四海皆准的。
3．Http是应用协议而非传输协议
这点在后面各大网站的API分析中有很明显的体现，其实有些网站已经走到了SOAP的老路上，说是REST的理念设计，其实是作了一套私有的SOAP协议，因此称之为REST风格的自定义SOAP协议。
4．无状态，自包含
这点其实不仅仅是对于REST来说的，作为接口设计都需要能够做到这点，也是作为可扩展和高效性的最基本的保证，就算是使用SOAP的WebService也是一样。
REST vs SOAP
成熟度：
SOAP虽然发展到现在已经脱离了初衷，但是对于异构环境服务发布和调用，以及厂商的支持都已经达到了较为成熟的情况。不同平台，开发语言之间通过SOAP来交互的web service都能够较好的互通（在部分复杂和特殊的参数和返回对象解析上，协议没有作很细致的规定，导致还是需要作部分修正）
REST国外很多大网站都发布了自己的开发API，很多都提供了SOAP和REST两种Web Service，根据调查部分网站的REST风格的使用情况要高于SOAP。但是由于REST只是一种基于Http协议实现资源操作的思想，因此各个网站的REST实现都自有一套，在后面会讲诉各个大网站的REST API的风格。也正是因为这种各自实现的情况，在性能和可用性上会大大高于SOAP发布的web service，但统一通用方面远远不及SOAP。由于这些大网站的SP往往专注于此网站的API开发，因此通用性要求不高。
ASF上考虑发布REST风格的Web Service，可以参考几大网站的设计（兄弟公司的方案就是参考了类似于flickr的设计模式），但是由于没有类似于SOAP的权威性协议作为规范，REST实现的各种协议仅仅只能算是私有协议，当然需要遵循REST的思想，但是这样细节方面有太多没有约束的地方。REST日后的发展所走向规范也会直接影响到这部分的设计是否能够有很好的生命力。
总的来说SOAP在成熟度上优于REST。
效率和易用性：
SOAP协议对于消息体和消息头都有定义，同时消息头的可扩展性为各种互联网的标准提供了扩展的基础，WS-*系列就是较为成功的规范。但是也由于SOAP由于各种需求不断扩充其本身协议的内容，导致在SOAP处理方面的性能有所下降。同时在易用性方面以及学习成本上也有所增加。
REST被人们的重视，其实很大一方面也是因为其高效以及简洁易用的特性。这种高效一方面源于其面向资源接口设计以及操作抽象简化了开发者的不良设计，同时也最大限度的利用了Http最初的应用协议设计理念。同时，在我看来REST还有一个很吸引开发者的就是能够很好的融合当前Web2.0的很多前端技术来提高开发效率。例如很多大型网站开放的REST风格的API都会有多种返回形式，除了传统的xml作为数据承载，还有（JSON,RSS,ATOM）等形式，这对很多网站前端开发人员来说就能够很好的mashup各种资源信息。
因此在效率和易用性上来说，REST更胜一筹。
安全性：
这点其实可以放入到成熟度中，不过在当前的互联网应用和平台开发设计过程中，安全已经被提到了很高的高度，特别是作为外部接口给第三方调用，安全性可能会高过业务逻辑本身。
SOAP在安全方面是通过使用XML-Security和XML-Signature两个规范组成了WS-Security来实现安全控制的，当前已经得到了各个厂商的支持，.net ，php ，java 都已经对其有了很好的支持（虽然在一些细节上还是有不兼容的问题，但是互通基本上是可以的）。
REST没有任何规范对于安全方面作说明，同时现在开放REST风格API的网站主要分成两种，一种是自定义了安全信息封装在消息中（其实这和SOAP没有什么区别），另外一种就是靠硬件SSL来保障,但是这只能够保证点到点的安全，如果是需要多点传输的话SSL就无能为力了。安全这块其实也是一个很大的问题，今年在BEA峰会上看到有演示采用SAML2实现的网站间SSO，其实是直接采用了XML-Security和XML-Signature，效率看起来也不是很高。未来REST规范化和通用化过程中的安全是否也会采用这两种规范，是未知的，但是加入的越多，REST失去它高效性的优势越多。
应用设计与改造：
我们的系统要么就是已经有了那些需要被发布出去的服务，要么就是刚刚设计好的服务，但是开发人员的传统设计思想让REST的形式被接受还需要一点时间。同时在资源型数据服务接口设计上来说按照REST的思想来设计相对来说要容易一些，而对于一些复杂的服务接口来说，可能强要去按照REST的风格来设计会有些牵强。这一点其实可以看看各大网站的接口就可以知道，很多网站还要传入function的名称作为参数，这就明显已经违背了REST本身的设计思路。
而SOAP本身就是面向RPC来设计的，开发人员十分容易接受，所以不存在什么适应的过程。
总的来说，其实还是一个老观念，适合的才是最好的
技术没有好坏，只有是不是合适，一种好的技术和思想被误用了，那么就会得到反效果。REST和SOAP各自都有自己的优点，同时如果在一些场景下如果去改造REST，其实就会走向SOAP（例如安全）。
REST对于资源型服务接口来说很合适，同时特别适合对于效率要求很高，但是对于安全要求不高的场景。而SOAP的成熟性可以给需要提供给多开发语言的，对于安全性要求较高的接口设计带来便利。所以我觉得纯粹说什么设计模式将会占据主导地位没有什么意义，关键还是看应用场景。
同时很重要一点就是不要扭曲了REST现在很多网站都跟风去开发REST风格的接口，其实都是在学其形，不知其心，最后弄得不伦不类，性能上不去，安全又保证不了，徒有一个看似象摸象样的皮囊。
REST设计的几种形式
参看了几个大型网站的REST风格的API设计，这里做一下大致的说明：
FaceBook:
请求消息：
在URI设计上采取了类似于REST的风格。例如对于friends的获取，就定义为friends.get，前面部分作为资源定义，后面是具体的操作，其他的API也是类似，资源+操作，因此就算使用http的get方法都可能作了update的操作，其实已经违背了REST的思想，但是说到，其实那么复杂的业务接口设计下，要通过RUCD来抽象所有的接口基本是不实际的。在URI定义好以后，还有详细的参数定义，包括类型以及是否必选。
响应消息：
有多种方式，XML,JSON。XML有XSD作为参考。有点类似于没有Head的SOAP，只不过这里将原来可以定义在WSDL中的XSD抽取出来了。
Flickr:
请求消息：
http://api.flickr.com/services/rest/?method=flickr.test.echo&name=value
这里就可以很明显看出它所定制的REST请求其实和RPC没有什么太大的区别。
消息返回：
正确处理返回
<?xml version="1.0" encoding="utf-8" ?>
<rsp stat="ok">
[xml-payload-here]
</rsp>
错误处理返回
<?xml version="1.0" encoding="utf-8" ?>
<rsp stat="fail">
<err code="[error-code]" msg="[error-message]" />
</rsp>
根据返回可以看出已经违背了REST的思想，还是把Http协议作为传输承载协议，并没有真正意义上使用Http协议作为资源访问和操作协议。
总的来说，只是形式上去模仿REST，自己搞了一套私有协议。
Ebay：
请求消息：
采用xml作为承载，类似于SOAP，不过去除SOAP消息的封装和包头，同时在请求中附加了认证和警告级别等附加信息。
消息返回：
类似于SOAP消息，不过删除了SOAP的封装和包头，同时在返回结构中增加了消息处理结果以及版本等附加信息。
这个很类似于当前Axis2框架的做法，将SOAP精简，同时根据自身需求丰富了安全，事务等协议内容。
Yahoo Maps：
请求消息：
http://local.yahooapis.com/MapsService/V1/geocode?appid=YahooDemo&street=701+First+Ave&city=Sunnyvale&state=CA
采用REST推荐的方式，URI+Parameters。
返回消息：
<?xml version="1.0" encoding="UTF-8"?>
<ResultSet xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
xmlns="urn:yahoo:maps"
xsi:schemaLocation="urn:yahoo:maps http://local.yahooapis.com/MapsService/V1/GeocodeResponse.xsd">
<Result precision="address">
<Latitude>37.416384</Latitude>
<Longitude>-122.024853</Longitude>
<Address>701 FIRST AVE</Address>
<City>SUNNYVALE</City>
<State>CA</State>
<Zip>94089-1019</Zip>
<Country>US</Country>
</Result>
</ResultSet>
SOAP的精简xml返回，其他信息，例如出错码等信息由Http协议头来承载。
YouTube：
请求消息：
http://www.youtube.com/api2_rest?method=youtube.users.get_profile&dev_id=YOUR_DEV_ID&user=YOUTUBE_USER_NAME
可以看到对于资源操作的URI定义也是参数的一部分。
返回消息：
<?xml version="1.0" encoding="utf-8"?>
<ut_response status="ok">
<user_profile>
<first_name>YouTube</first_name>
<last_name>User</last_name>
<about_me>YouTube rocks!!</about_me>
<age>30</age>
<video_upload_count>7</video_upload_count>
</user_profile>
</ut_response>
自定义的类SOAP消息。
Amazon：
请求消息：
https://Amazon FPS web service end point/?AWSAccessKeyId=Your AWSAccessKeyId
&Timestamp=[Current timestamp] &Signature=[Signature calculated from hash of Action and Timestamp]
&SignatureVersion=[Signature calculated from hash of Action and Timestamp]
&Version=[Version of the WSDL specified in YYYY-MM-DD format] &Action=[Name of the API]
¶meter1=[Value of the API parameter1] ¶meter2=[Value of the API parameter2]
&...[API parameters and their values]
返回消息：
类似于SOAP的自有协议，消息体中包含了消息状态等附加信息。
总结：
看了上面那么多网站的设计，总结一下主要有这么几种设计方式。
请求消息设计：
1． 基本符合REST标准方式：资源URI定义（资源．操作）+参数。这类设计如果滥用get去处理其他类型的操作，那么和2无异。
2． REST风格非REST思想：资源URI定义+参数（包含操作方法名）。其实就是RPC的REST跟风。
3． 类似于SOAP消息，自定义协议，以xml作为承载。（可扩展，例如鉴权，访问控制等），不过那就好比自己定义了一套SOAP和SOAP extends。大型的有实力的网站有的采取此种做法。
响应消息设计：
1. REST标准方式，将Resource State传输返回给客户端，Http消息作为应用协议而非传输协议
2. 以XML作为消息承载体，Http作为消息传输协议，处理状态自包含。
3. 自定义消息格式，类似于SOAP，提供可扩展部分。
作为遵循REST的理念来看我的选择是响应1和请求1的设计。
REST和ASF的集成
ASF要集成REST就现在来看有两种比较合适的方法。
一．就是采用Axis2的REST实现，这种方式的好处就是开发周期短，容易集成，但是请求和响应的格式无法改变，资源URI设计受限，Axis2的REST其实就是将SOAP消息精简，请求的时候删除了SOAP的头，响应的时候仅仅返回资源信息，如果提供xsd就可以被各种客户端所解析。并非真正的REST。
二．就是采用Restlet开源框架，将Restlet开源框架集成到ASF中，由于Restlet本身就是可内嵌的应用框架，因此集成不成问题，同时Restlet框架只是API结构框架，因此实现和定义完全分开，集成Restlet以后可以自己实现其中的解析引擎也可以采用默认提供的引擎，同时对于内嵌Jetty等多种开源项目的支持，将更多优势融入到了Rest中。看了一下国内也有很多朋友已经关注Restlet开源项目，看了它的架构设计，个人觉得还是比较灵活和紧凑的。
题外话
在写这篇文章以前写了一篇调研报告群发给各个架构师们参考，期待反馈。下午正好和我们的首席架构师聊了一会儿。其实我和他的感觉是一样的，REST是否真的在我们现有的服务框架中需要集成，理解了REST的思想再去看应用场景，那么可以发现如果要完全遵循REST的设计理念来设计接口的话，那么强要去改变现有已经存在的或者还未开发的接口就会落入为了技术而技术，为了潮流而跟风的近地。当然并不否认REST的好，其实我们兄弟公司的一些业务场景有部分的接口十分合适这类设计，面向资源，高效，简洁，易用都能够体现出它的价值。我们将会和我们的兄弟公司合作，也会参考他们的设计理念，在参考当前各个网站的实现情况下，部分的采用这类形式的发布，提供给第三方的ISV，无疑是我现在把REST融入到ASF中最好的理由。
有了需求去做才不会陷入为了技术而技术，毕竟技术是由商业价值驱动的，同样社会上充斥着各种技术的鼓吹，如果稍不留神就会陷入跟风的潮流中。
SOAP的Web Service解决方案虽然较为成熟，且安全性较好，但是使用门槛较高，在大并发情
况下会有性能问题，在互联网上使用不太普及，因此并不太适合Web 2.0网站服务使用，目前大
量的Web 2.0网站使用另外一种解决方案——REST。
REST（Representational State Transfer）是一种轻量级的Web Service架构风格，其实现和操
作明显比SOAP和XML-RPC更为简洁，可以完全通过HTTP协议实现，还可以利用缓存Cache来
提高响应速度，性能、效率和易用性上都优于SOAP协议。
REST架构遵循了CRUD原则，CRUD原则对于资源只需要四种行为：Create（创建）、Read（
读取）、Update（更新）和Delete（删除）就可以完成对其操作和处理。这四个操作是一种原
子操作，即一种无法再分的操作，通过它们可以构造复杂的操作过程，正如数学上四则运算是数
字的最基本的运算一样。
REST架构让人们真正理解我们的网络协议HTTP本来面貌，对资源的操作包括获取、创建、修改
和删除资源的操作正好对应HTTP协议提供的GET、POST、PUT和DELETE方法，因此REST把
HTTP对一个URL资源的操作限制在GET、POST、PUT和DELETE这四个之内。这种针对网络应
用的设计和开发方式，可以降低开发的复杂性，提高系统的可伸缩性。
REST的设计准则
REST架构是针对Web应用而设计的，其目的是为了降低开发的复杂性，提高系统的可伸缩
性。REST提出了如下设计准则：
网络上的所有事物都被抽象为资源（resource）；
每个资源对应一个唯一的资源标识符（resource identifier）；
通过通用的连接器接口（generic connector interface）对资源进行操作；
对资源的各种操作不会改变资源标识符；
所有的操作都是无状态的（stateless）。
REST是一种全新的Web开发过程中的思维方式：通过URL来设计系统结构。REST是一套简单的
设计原则、一种架构风格（或模式），不是一种具体的标准或架构
web services概念：
soap采用XML格式的封包，XML基于文本，任何系统都可以支持。SOAP采用通用的HTTP通讯协议作为第一个传递协议。
WSDL接口文件
WEB SERVICES服务端输出了什么服务，客户端需要调用什么服务就由WSDL接口文件来进行辩认。一个SOAP格式的封包，定义了此WEB SERVICES的服务函数，地址，服务名和端口名称。双方只要拥有这个文件，就能准确无误地进行数据交换和沟通。
WEB SERVICES服务端提供服务接口，客户端只要得到该接口，并调用接口提供的服务函数，就能命令WEB SERVICES服务端将结果返回。服务接口就好比双方的契约一样，只要双方都遵守这个约定，合作就能成功。
WEB SERVICES不会改变程序的实现模式，可以使用任何程序语言和组件模型，WEB SERVICES仅仅起到集成各系统的粘合剂的作用。
WEB SERVICES的缺点：客户端要得到WEB SERVICES服务端返回的结果需要往返传递和转换SOAP封包，从效率上讲不是特别理想。
DELPHI WEB SERVICES控件介绍：
THTTPRIO 通过HTTP和SOAP封包调用远程WEB SERVICES
THTTPREQRESP 用WININET.DLL传递WEB SERVICES返回的结果，或者取回客户端的请求信息
TOPTOSOAPDOMCONVERT 将OBJECT PASCAL调用的WEB SERVICES转换为SOAP封包，并且把WEB SERVICES返回的结果转换为OBJECT PASCAL的格式
TSOAPCONNECTION 客户端与WEB SERVICES间的联系方式，用以调用WEB SERVICES中的应用程序服务器
THTTPSOAPDISPATCHER 拦截HTTP请求，并把请求信息分派给THTTPSOAPPASCALINVOKER组件以命令WEB SERVICES提供的对应函数
TWSDLHTMLPUBLISH 自动产生WSDL信息
THTTPSOAPPASCALINVOKER 根据HTTP请求信息调用相应的函数
DELPHI WEB SERVICES各控件之间的关系图：
客户端<--->THTTPRIO<--->TOPTOSOAPDOMCONVERT<--->THTTPREQRESP<--->
THTTPSOAPDISPATCHER<--->THTTPSOAPPASCALINVOKER<--->TWSDLHTMLPUBLISH
<--->WEB SERVICES<--->WEB服务应用程序端
WEB SERVICES服务端开发步骤：
1.运行SOAP SERVER APPLICATION向导
2.定义一个接口，并在接口中定义对外提供的服务函数
3.通过程序语言实现这个接口，实现这些服务函数的功能
4.输出一个XML格式的WSDL接口文件，如果是ISAPI或者CGI类型的服务器程序，就需要发布到虚拟目录下。
WEB SERVICES客户端开发步骤：
1.新建一个应用程序
2.导入WEB SERVICES 服务接口单元，如果是使用DELPHI开发的WEB SERVICES服务端，直接将该文件加入到客户端工程就可以了，如果是用其它语言工具编写的WEB SERVICES服务端，要使用WEB SERVICES提供的向导WSDL IMPORTER，告诉它WSDL文件的位置，它就会自动将其转换为OBJECT PASCAL代码。
3.调用服务接口对外提供的服务函数，取得WEB SERVICES服务端处理的结果。
CREATE INTERFACE FOR SOAP MODULE?
选择YES，自动创建接口单元和接口实现单元文件。也可以用SOAP SERVER INTERFACE向导弹出上面的问题对话框。设置好SERVICES NAME
注意事项：
接口必须从IINVOKABLE继承，并且在INITIALIZATION部分注册
TYPE
IWSGETSYSMSG=INTERFACE(IINVOKABLE)
......
INITIALIZATION
INVREGISTRY.REGISTERINTERFACE(TYPEINFO(IWSGETSYSMSG))；
服务函数要使用STDCALL机制，这样客户端在调用时可以保证能取得正确的函数，否则可能找不到函数。函数的返回值必须是STRING类型的，如果不是STRING类型的值，必须将其转换为BASE64格式传递。
THTTPRIO使用说明：
用来连接远程的WEB SERVICES的
WSDLLOCATION与URL是两个互斥的属性，只要其中之一设置了属性，另外一个就会自动清空
WSDLLOCATION指WEB SERVICES输出的WDDL文件的地址，它需要同时指定PORT和SERVICE名称；URL指SOAP的地址，它必须是THTTPSOAPDISPATCHER组件指定的PATHINFO的名称，通常为SOAP，它不用指定PORT和SERVICE名称。
WSDLLOCATION的地址一般是HTTP://主机名/应用程序员/WSDL/接口名. 例如:HTTP://localhost:8081/pwsdemo1.wsdemo1/WSDL/iwsgetsysmsg
URL地址一般是HTTP://主机名/应用程序员/SOAP/接口名
一般情况下多使用WSDLLOCATION连接WEB应用程序服务器
客户端调用WEB SERVICES 服务函数:
uses WsGetSysMsg; // 引用导入的接口单元
var
rio: iWsGetSysMsg;
begin
rio := HTTPRIO1 as iWsGetSysMsg;
rio.GetSysMsg(edit1.text);
iis权限设置:
选中WEBSERVICES虚拟目录,单击右键,选择属性,将执行权限设置为 脚本和可执行文件,否则无法调用.
客户端要调用WEB SERVICES,关键是取得WSDL接口文件,而这个文件的取得又依靠WSDL地址.
UDDI
以结构化的方式来注册,管理WEB SERVICES信息,以达到资源共享,共建的目的.通过它可以注册,搜寻WEB SERVICES服务信息,以便企业能够通过提供的注册平台来集成各系统.
WEB SERVICES的传输会损耗一些效率,SOAP封包传输时也会增加数据的尺寸,对于网络传输是一个负担.
提高效率的方法:
1.WSDL文件的内容主要给客户端使用的,在什么位置并不重要,只要客户端能够取得这个文件就可以了.可以避免WSDL文件,将它从服务器端下载到本地并保存为*.WSDL文件.
2.压缩SOAP封包,首先是要压缩传递的内容,然后再封装成SOAP封包进行传递.压缩算法是以二进制形式传递的,在SOAP中必须转换为BASE64格式,传递时一定要进行格式转换.
2012年5月22日
program Monitor;
// {$APPTYPE CONSOLE}
uses
Winapi.Windows,
System.SysUtils,
ProcLib in 'ProcLib.pas';
var
Mutex: HWND;
const
c_AppName = 'server.exe';
begin
Mutex := Winapi.Windows.CreateMutex(nil, False, 'Monitor');
if (GetLastError = ERROR_ALREADY_EXISTS) or (Mutex = 0) then
Exit;
G_ExeFile := ExtractFilePath(ParamStr(0)) + c_AppName;
while True do
begin
Sleep(2000);
if ProcessRunning(c_AppName) then
Continue;
if G_ExeFile = '' then
Continue;
Exec(G_ExeFile);
end;
end.
unit ProcLib;
interface
uses
Winapi.Windows, System.SysUtils, Winapi.PsAPI,
Winapi.TlHelp32, Winapi.ShellAPI;
function ProcessRunning(ExeName: string): Boolean;
procedure Exec(FileName: string);
var
G_ExeFile: string = '';
implementation
function ProcessFileName(PID: DWORD): string;
var
Handle: THandle;
begin
Result := '';
Handle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,
False, PID);
if Handle <> 0 then
try
SetLength(Result, MAX_PATH);
if GetModuleFileNameEx(Handle, 0, PChar(Result), MAX_PATH) > 0 then
SetLength(Result, StrLen(PChar(Result)))
else
Result := '';
finally
CloseHandle(Handle);
end;
end;
function ProcessRunning(ExeName: string): Boolean;
var
SnapProcHandle: THandle;
NextProc: Boolean;
ProcEntry: TProcessEntry32;
ProcFileName: string;
begin
Result := False;
SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if SnapProcHandle = INVALID_HANDLE_VALUE then
Exit;
try
ProcEntry.dwSize := SizeOf(ProcEntry);
NextProc := Process32First(SnapProcHandle, ProcEntry);
while NextProc do
begin
if ProcEntry.th32ProcessID <> 0 then
begin
ProcFileName := ProcessFileName(ProcEntry.th32ProcessID);
if ProcFileName = '' then
ProcFileName := ProcEntry.szExeFile;
if SameText(ExtractFileName(ProcFileName), ExeName) then
begin
Result := True;
Break;
end;
end;
NextProc := Process32Next(SnapProcHandle, ProcEntry);
end;
finally
CloseHandle(SnapProcHandle);
end;
end;
procedure Exec(FileName: string);
var
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := SW_SHOWDEFAULT;
if not CreateProcess(PChar(FileName), nil, nil, nil, False,
CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
PChar(ExtractFilePath(FileName)), StartupInfo, ProcessInfo) then
Exit;
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
end;
end.
unit uDBJson;
interface
{$HINTS OFF}
uses
SysUtils, Classes, Variants, DB, DBClient, SuperObject;
type
TTableJSon = class
private const
cstFieldType = 'FieldType';
const
cstFieldName = 'FieldName';
const
cstFieldSize = 'FieldSize';
const
cstJsonType = 'JsonType';
const
cstRequired = 'Required';
const
cstFieldIndex = 'FieldIndex';
const
cstCols = 'Cols';
const
cstData = 'Data';
public
class function DataSetToJson(DataSet: TDataSet): ISuperObject;
class function DataSetToJson2(DataSet: TDataSet): string;
class function CreateFieldByJson(Fields: TFieldDefs;
ColsJson: ISuperObject): Boolean;
class procedure ImportDataFromJSon(DataSet: TDataSet;
DataJson: ISuperObject);
class function JSonToClientDataset(CDS: TClientDataSet; Json: ISuperObject)
: Boolean;
class function GetValue(Json: ISuperObject; const Name: string): Variant;
class function CreateJsonValue(Json: ISuperObject; const Name: string;
const Value: Variant): Boolean;
class function CreateJsonValueByField(Json: ISuperObject;
Field: TField): Boolean;
class function GetValue2Field(Field: TField;
JsonValue: ISuperObject): Variant;
end;
implementation
uses TypInfo, encddecd;
{ TTableJSon }
class function TTableJSon.JSonToClientDataset(CDS: TClientDataSet;
Json: ISuperObject): Boolean;
var
ColsJson: ISuperObject;
begin
Result := False;
if Json = nil then
Exit;
CDS.Close;
CDS.Data := Null;
// 创建字段
ColsJson := Json.O[cstCols];
CreateFieldByJson(CDS.FieldDefs, ColsJson);
if CDS.FieldDefs.Count > 0 then
CDS.CreateDataSet;
ImportDataFromJSon(CDS, Json.O[cstData]);
Result := True;
end;
class function TTableJSon.CreateFieldByJson(Fields: TFieldDefs;
ColsJson: ISuperObject): Boolean;
var
SubJson: ISuperObject;
ft: TFieldType;
begin
Result := False;
Fields.DataSet.Close;
Fields.Clear;
for SubJson in ColsJson do
begin
ft := TFieldType(GetEnumValue(TypeInfo(TFieldType),
'ft' + SubJson.S[cstFieldType]));
if ft = ftAutoInc then // 自增字段不能录入，必须更改
ft := ftInteger;
Fields.Add(SubJson.S[cstFieldName], ft, SubJson.I[cstFieldSize],
SubJson.B[cstRequired]);
end;
Result := True;
end;
class function TTableJSon.CreateJsonValue(Json: ISuperObject;
const Name: string; const Value: Variant): Boolean;
begin
Result := False;
Json.O[Name] := SO(Value);
Result := True;
end;
class function TTableJSon.CreateJsonValueByField(Json: ISuperObject;
Field: TField): Boolean;
begin
Result := False;
if Field Is TDateTimeField then
Json.O[Field.FieldName] := SO(Field.AsDateTime)
else if Field is TBlobField then
Json.S[Field.FieldName] := EncodeString(Field.AsString)
else
Json.O[Field.FieldName] := SO(Field.Value);
Result := True;
end;
class function TTableJSon.GetValue(Json: ISuperObject;
const Name: string): Variant;
begin
case Json.DataType of
stNull:
Result := Null;
stBoolean:
Result := Json.B[Name];
stDouble:
Result := Json.D[Name];
stCurrency:
Result := Json.C[Name];
stInt:
Result := Json.I[Name];
stString:
Result := Json.S[Name];
end;
end;
class function TTableJSon.GetValue2Field(Field: TField;
JsonValue: ISuperObject): Variant;
begin
if JsonValue.DataType = stNull then
Result := Null
else if Field is TDateTimeField then
Result := JavaToDelphiDateTime(JsonValue.AsInteger)
else if (Field is TIntegerField) or (Field is TLargeintField) then
Result := JsonValue.AsInteger
else if Field is TNumericField then
Result := JsonValue.AsDouble
else if Field is TBooleanField then
Result := JsonValue.AsBoolean
else if Field is TStringField then
Result := JsonValue.AsString
else if Field is TBlobField then
Result := DecodeString(JsonValue.AsString)
end;
class procedure TTableJSon.ImportDataFromJSon(DataSet: TDataSet;
DataJson: ISuperObject);
var
SubJson: ISuperObject;
iter: TSuperObjectIter;
begin
if not DataSet.Active then
DataSet.Open;
DataSet.DisableControls;
try
for SubJson in DataJson do
begin
DataSet.Append;
if ObjectFindFirst(SubJson, iter) then
begin
repeat
if DataSet.FindField(iter.Ite.Current.Name) <> nil then
DataSet.FindField(iter.Ite.Current.Name).Value :=
GetValue2Field(DataSet.FindField(iter.Ite.Current.Name),
iter.Ite.Current.Value);
until not ObjectFindNext(iter);
end;
DataSet.Post;
end;
finally
DataSet.EnableControls;
end;
end;
class function TTableJSon.DataSetToJson(DataSet: TDataSet): ISuperObject;
procedure GetFieldTypeInfo(Field: TField; var Fieldtyp, JsonTyp: string);
begin
Fieldtyp := GetEnumName(TypeInfo(TFieldType), ord(Field.DataType));
Delete(Fieldtyp, 1, 2);
if Field is TStringField then
JsonTyp := 'string'
else if Field is TDateTimeField then
JsonTyp := 'integer'
else if (Field is TIntegerField) or (Field is TLargeintField) then
JsonTyp := 'integer'
else if Field is TCurrencyField then
JsonTyp := 'currency'
else if Field is TNumericField then
JsonTyp := 'double'
else if Field is TBooleanField then
JsonTyp := 'boolean'
else
JsonTyp := 'variant';
end;
var
sj, aj, sj2: ISuperObject;
I: Integer;
Fieldtyp, JsonTyp: string;
List: TStringList;
begin
sj := SO();
// 创建列
aj := SA([]);
List := TStringList.Create;
try
List.Sorted := True;
for I := 0 to DataSet.FieldCount - 1 do
begin
sj2 := SO();
GetFieldTypeInfo(DataSet.Fields[I], Fieldtyp, JsonTyp);
sj2.S[cstFieldName] := DataSet.Fields[I].FieldName;
sj2.S[cstFieldType] := Fieldtyp;
sj2.S[cstJsonType] := JsonTyp;
sj2.I[cstFieldSize] := DataSet.Fields[I].Size;
sj2.B[cstRequired] := DataSet.Fields[I].Required;
sj2.I[cstFieldIndex] := DataSet.Fields[I].Index;
aj.AsArray.Add(sj2);
List.Add(DataSet.Fields[I].FieldName + '=' + JsonTyp);
end;
sj.O['Cols'] := aj;
// 创建数据集的数据
DataSet.DisableControls;
DataSet.First;
aj := SA([]);
while not DataSet.Eof do
begin
sj2 := SO();
for I := 0 to DataSet.FieldCount - 1 do
begin
if VarIsNull(DataSet.Fields[I].Value) then
sj2.O[DataSet.Fields[I].FieldName] := SO(Null)
else
begin
CreateJsonValueByField(sj2, DataSet.Fields[I]);
end;
end;
aj.AsArray.Add(sj2);
DataSet.Next;
end;
sj.O['Data'] := aj;
Result := sj;
finally
List.Free;
DataSet.EnableControls;
end;
end;
class function TTableJSon.DataSetToJson2(DataSet: TDataSet): string;
procedure GetFieldTypeInfo(Field: TField; var Fieldtyp, JsonTyp: string);
begin
Fieldtyp := GetEnumName(TypeInfo(TFieldType), ord(Field.DataType));
Delete(Fieldtyp, 1, 2);
if Field is TStringField then
JsonTyp := 'string'
else if Field is TDateTimeField then
JsonTyp := 'integer'
else if (Field is TIntegerField) or (Field is TLargeintField) then
JsonTyp := 'integer'
else if Field is TCurrencyField then
JsonTyp := 'currency'
else if Field is TNumericField then
JsonTyp := 'double'
else if Field is TBooleanField then
JsonTyp := 'boolean'
else
JsonTyp := 'variant';
end;
var
sj, aj, sj2: ISuperObject;
I: Integer;
Fieldtyp, JsonTyp: string;
List: TStringList;
begin
sj := SO();
// 创建列
aj := SA([]);
List := TStringList.Create;
try
List.Sorted := True;
for I := 0 to DataSet.FieldCount - 1 do
begin
sj2 := SO();
GetFieldTypeInfo(DataSet.Fields[I], Fieldtyp, JsonTyp);
sj2.S[cstFieldName] := DataSet.Fields[I].FieldName;
sj2.S[cstFieldType] := Fieldtyp;
sj2.S[cstJsonType] := JsonTyp;
sj2.I[cstFieldSize] := DataSet.Fields[I].Size;
sj2.B[cstRequired] := DataSet.Fields[I].Required;
sj2.I[cstFieldIndex] := DataSet.Fields[I].Index;
aj.AsArray.Add(sj2);
List.Add(DataSet.Fields[I].FieldName + '=' + JsonTyp);
end;
sj.O['Cols'] := aj;
// 创建数据集的数据
DataSet.DisableControls;
DataSet.First;
aj := SA([]);
while not DataSet.Eof do
begin
sj2 := SO();
for I := 0 to DataSet.FieldCount - 1 do
begin
if VarIsNull(DataSet.Fields[I].Value) then
sj2.O[DataSet.Fields[I].FieldName] := SO(Null)
else
begin
CreateJsonValueByField(sj2, DataSet.Fields[I]);
end;
end;
aj.AsArray.Add(sj2);
DataSet.Next;
end;
sj.O['Data'] := aj;
Result := sj.AsString;
finally
List.Free;
DataSet.EnableControls;
end;
end;
end.
unit untMemoryPool;
interface
{$WARNINGS OFF}
uses
System.Classes, System.SysUtils, Winapi.Windows;
type
//Node for block memory
pMemNode = ^TMemNode;
TMemNode = record
Free : Boolean; //Is free?
FSize: Integer; //Block Size
FAddr: Pointer; //Address pointer to memory allocated
FNext: pMemNode; //Next block pointer
FPrev: pMemNode; //Block befor
end;
//Memory pool class
TMemoryPool = class(TObject)
private
FBlkSize: Integer; //Block size
FBlkCnt : Integer; //Memory bock count each time allocate
FMemHead: pMemNode; //Memory list
FreeHead: pMemNode; //Free memory start position
FMemTail: pMemNode; //Tail of current memory
FLock : TRTLCriticalSection;
procedure InitLock;
procedure Lock;
procedure UnLock;
procedure UnInitLock;
procedure GetResource(ABlocks: Integer);
procedure FreeResource;
public
constructor Create(const ABlocks: Integer = 10; const ABlockSize: Integer = 1024);
destructor Destroy; override;
//Get a free buffer
function GetBuffer: Pointer;
//After use the buffer
function FreeBuffer(const ABuffer: Pointer): Boolean;
published
property BlockSize: Integer read FBlkSize;
end;
implementation
{ TMemoryPool }
{******************************************************************************}
{* Procedure: Create *}
{* Purpose: constructor of TMemoryPool. *}
{* Paramaters: ABlocks -- Block to allocate when create. *}
{* ABlockSize -- Each block size. *}
{******************************************************************************}
constructor TMemoryPool.Create(const ABlocks, ABlockSize: Integer);
begin
InitLock;
FBlkCnt := ABlocks;
FBlkSize:= ABlockSize;
FMemHead:= nil;
FMemTail:= nil;
FreeHead:= nil;
GetResource(ABlocks);
end;
{******************************************************************************}
{* Procedure: Destroy *}
{* Purpose: Destrucotr of TMemoryPool. *}
{* Paramaters: None. *}
{******************************************************************************}
destructor TMemoryPool.Destroy;
begin
FreeResource;
UnInitLock;
inherited;
end;
{******************************************************************************}
{* Function: FreeBuffer *}
{* Purpose: Free memory buffer allocated. *}
{* Paramaters: ABuffer -- Buffer address to free. *}
{* Return: True -- Block is free. *}
{* False -- Free error or the block not found. *}
{******************************************************************************}
function TMemoryPool.FreeBuffer(const ABuffer: Pointer): Boolean;
var
m_pTmp: pMemNode;
begin
Result:= false;
Lock;
try
if (nil = ABuffer) then exit;
m_pTmp:= FMemHead;
while (m_pTmp <> nil) do
begin
if (ABuffer = m_pTmp.FAddr) then
begin
if FreeHead = nil then
FreeHead:= FMemTail
else
FreeHead:= FreeHead.FPrev; //Move free head back
//Swap two blocks's content
m_pTmp.Free := false;
m_pTmp.FAddr:= FreeHead.FAddr;
FreeHead.Free := true;
FreeHead.FAddr:= ABuffer;
Result:= true;
exit;
end;
m_pTmp:= m_pTmp.FNext;
// Not find the block, exit
if (m_pTmp = FreeHead) then break;
end;
finally
UnLock;
end;
end;
{******************************************************************************}
{* Procedure: FreeResource *}
{* Purpose: Free all memory allocated. *}
{* Paramaters: None. *}
{******************************************************************************}
procedure TMemoryPool.FreeResource;
var
m_pNode: pMemNode;
m_pTmp : pMemNode;
begin
m_pNode:= FMemHead;
try
while (m_pNode <> nil) do
begin
m_pTmp:= m_pNode;
m_pNode:= m_pNode.FNext;
FreeMem(m_pTmp.FAddr);
Dispose(m_pTmp);
end;
except
end;
FMemHead:= nil;
end;
{******************************************************************************}
{* Function: GetBuffer *}
{* Purpose: Get a memroy block buffer. *}
{* Paramaters: None. *}
{* Return: Pointer -- A pointer pointer to buffer. *}
{******************************************************************************}
function TMemoryPool.GetBuffer: Pointer;
begin
Lock;
try
//If there's no free memroy, allocate new memory
if (FreeHead = nil) then
GetResource(FBlkCnt);
//Return free memory head address
Result:= FreeHead.FAddr;
//Mark the block is not free
FreeHead.Free:= false;
//Move free head pointer forward
FreeHead:= FreeHead.FNext;
finally
UnLock;
end;
end;
{******************************************************************************}
{* Procedure: GetResource *}
{* Purpose: Allocate memroy. *}
{* Paramaters: ABlocks -- How many blocks to allocate. *}
{******************************************************************************}
procedure TMemoryPool.GetResource(ABlocks: Integer);
var
m_pNode: pMemNode;
m_iTmp : Integer;
begin
if (ABlocks <= 0) or (FBlkSize <= 0) then exit;
//Get new memory block
new(m_pNode);
m_pNode.Free := true;
m_pNode.FSize:= FBlkSize;
m_pNode.FPrev:= FMemTail;
GetMem(m_pNode.FAddr, FBlkSize);
m_pNode.FNext:= nil;
//If the memroy block list is empty, assign head
if FMemHead = nil then
begin
FMemHead:= m_pNode;
FMemTail:= FMemHead;
FreeHead:= FMemHead;
end
else begin
FMemTail.FNext:= m_pNode;
FMemTail:= m_pNode;
end;
if (FreeHead = nil) then
FreeHead:= m_pNode;
for m_iTmp:= 1 to ABlocks - 1 do
begin
new(m_pNode);
m_pNode.Free := true;
m_pNode.FSize:= FBlkSize;
m_pNode.FNext:= nil;
m_pNode.FPrev:= FMemTail;
GetMem(m_pNode.FAddr, FBlkSize);
FMemTail.FNext:= m_pNode;
FMemTail:= m_pNode;
end;
end;
procedure TMemoryPool.InitLock;
begin
InitializeCriticalSection(FLock);
end;
procedure TMemoryPool.Lock;
begin
EnterCriticalSection(FLock);
end;
procedure TMemoryPool.UnInitLock;
begin
DeleteCriticalSection(FLock);
end;
procedure TMemoryPool.UnLock;
begin
LeaveCriticalSection(FLock);
end;
end.
2012年5月10日
function CnPYIndex(const CnString: string): string;
{
返回中文的拼音首字母
}
const
ChinaCode: array[0..25, 0..1] of Integer = ((1601, 1636), (1637, 1832), (1833, 2077),
(2078, 2273), (2274, 2301), (2302, 2432), (2433, 2593), (2594, 2786), (9999, 0000),
(2787, 3105), (3106, 3211), (3212, 3471), (3472, 3634), (3635, 3722), (3723, 3729),
(3730, 3857), (3858, 4026), (4027, 4085), (4086, 4389), (4390, 4557), (9999, 0000),
(9999, 0000), (4558, 4683), (4684, 4924), (4925, 5248), (5249, 5589));
var
i, j, HzOrd, l_iHz: Integer;
Hz: AnsiString;
begin
i := 1;
l_iHz :=1;
while i <= Length(CnString) do
begin
Hz := CnString[i];
if (Hz[l_iHz] >= #160) and (Hz[l_iHz +1] >= #160) then
begin
HzOrd := (Ord(Hz[l_iHz]) -160) *100+ Ord(Hz[l_iHz +1]) -160;
for j :=0to25do
begin
if (HzOrd >= ChinaCode[j][0]) and (HzOrd <= ChinaCode[j][1]) then
begin
Result := Result + Char(Byte('A') + j);//改A为a就全部是小写
Break;
end;
end;
end
else
Result := Result + CnString[i];
Inc(i);
end;
end;
最小化到任务栏
postmessage(Self.Handle,WM_SYSCOMMAND,SC_MINIMIZE,0);
最大化或还原
procedure Tf_MainForm.RzToolButton1Click(Sender: TObject);
var
abd: TAppBarData;
begin
inherited;
if WindowState=wsnormal then begin
WindowState := wsMaximized; // BorderStyleÎ为 bsNone
abd.cbSize := sizeof(abd);
SHAppBarMessage(ABM_GETTASKBARPOS, abd); //读取任务栏的区域
Self.Height := Self.Height - (abd.rc.Bottom - abd.rc.Top); //预留出任务栏的位置
(Sender as TRzToolButton).Hint :='还原';
(Sender as TRzToolButton).ImageIndex :=8;
end else if WindowState =wsmaximized then begin
WindowState :=wsNormal;
(Sender as TRzToolButton).Hint :='最大化';
(Sender as TRzToolButton).ImageIndex :=2;
end;
end;
移动无标题的窗体
procedure Tf_MainForm.RzPanel2MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
if Button=Mbleft then
begin
ReleaseCapture;
Perform(WM_NCLBUTTONDOWN,HTCAPTION,0);
end;
end;
无边框的窗体托动鼠标也能改变窗体的大小
protected
Procedure CreateParams(var Params: TCreateParams); override;
procedure Tf_MainForm.CreateParams(var Params: TCreateParams);
begin
BorderStyle := bsNone; // Îޱ߿ò´°ÌåÒ²Äܸı䴰ÌåµÄ´óС
inherited;
Params.ExStyle := Params.ExStyle or WS_EX_STATICEDGE;
Params.Style := Params.Style or WS_SIZEBOX;
end;
鼠标点击BUTTON弹出菜单
procedure Tf_MainForm.CreateParams(var Params: TCreateParams);
begin
BorderStyle := bsNone;
inherited;
Params.ExStyle := Params.ExStyle or WS_EX_STATICEDGE;
Params.Style := Params.Style or WS_SIZEBOX;
end;
窗体圆角处理
procedure Tf_MainForm.FormResize(Sender: TObject);
var hr:THandle;
begin
inherited;
hr:=createroundrectrgn(0,0,width,height,20,20);
setwindowrgn(handle,hr,true);
end;
窗体嵌入TABSHEET的一些方法
procedure Tf_MainForm.RzPageControl1Close(Sender: TObject;
var AllowClose: Boolean);
var
p: TRzPageControl;
t: TRzTabSheet;
begin
inherited;
p := sender as TRzPageControl;
t :=p.ActivePage;
if t.Caption <>'ϵͳµ¼º½' then begin
AllowClose := True;
TForm(t.Controls[0]).Close;
t.Free;
end else AllowClose :=False;
end;
function Tf_MainForm.CreateTab(const aCaption: string): TRzTabSheet;
begin
Result := TrzTabSheet.Create(RzPageControl1);
Result.PageControl := RzPageControl1;
Result.Caption := Acaption;
RzPageControl1.ActivePage := Result;
end;
function Tf_MainForm.ExistTab(const aCaption: string): boolean;
var
i: Integer;
begin
result := false;
for i := 0 to RzPageControl1.PageCount - 1 do
begin
if RzPageControl1.Pages[i].Caption = Acaption then
begin
result := true;
RzPageControl1.activepage := RzPageControl1.pages[i];
Break;
end;
end;
end;
procedure Tf_MainForm.openForm(aFormClass: TFormClass;
aOwner: TWinControl);
var i: Integer;
f: TForm;
begin
f := aFormClass.Create(aOwner);
f.Color :=c_color;
for i:=0 to f.ComponentCount-1 do begin
if f.Components[i] is TRzDBGrid then begin
TRzDBGrid(f.Components[i]).FixedColor := c_color;
end else if f.Components[i] is TRzDBNavigator then begin
TRzDBNavigator(f.Components[i]).Color :=c_color;
end;
end;
f.ManualDock(aOwner);
f.WindowState := wsMaximized;
f.Align := alClient;
f.Show;
end;
2012年5月7日
2012年4月6日
uses Datasnap.DSIntf
设置ZLIB压缩等级(zcFastest表示最快的压缩速度)
ZCompressStream(M, M0, zcFastest);
获取压缩前和压缩后的数据包的体积
iTest := DataPacketSize(VarToDataPacket(aDsp[i].Data));
iB := GetTickCount;
v[i] := CompressData(aDsp[i].Data);
iTime := GetTickCount - iB;
ShowMessage(IntToStr(iTime));
iTest := DataPacketSize(VarToDataPacket(v[i]));
获得俩组测试数据:
压缩前体积 压缩后体积 压缩用时 压缩比
57203 9292 15ms 6.15
25572 3700 16ms 6.91
