diff options
| author | Étienne Mollier <emollier@debian.org> | 2021-10-21 21:21:06 +0200 |
|---|---|---|
| committer | Étienne Mollier <emollier@debian.org> | 2021-10-21 21:21:06 +0200 |
| commit | 616a2611c88db3a7d9d0d722fa246f019b5f9221 (patch) | |
| tree | b785e1139bbc1540c8f558d5e2aec84470b50fec | |
| parent | 0bd4991abcc5911b1f33b3e31f92fb3fb1ed9a7f (diff) | |
New upstream version 0.27
53 files changed, 1744 insertions, 3189 deletions
@@ -7,16 +7,21 @@ use Module::Build; my $build = Module::Build->new( module_name => 'Tangence', requires => { + 'perl' => '5.026', + 'Encode' => 0, 'Exporter' => '5.57', + 'experimental' => 0, 'Feature::Compat::Try' => 0, 'Future' => '0.36', + 'Future::AsyncAwait' => '0.47', 'List::Util' => '1.29', - 'perl' => '5.014', + 'Object::Pad' => '0.51', 'Parser::MGC' => '0.04', 'Struct::Dumb' => 0, 'Sub::Util' => '1.40', - 'Syntax::Keyword::Match' => 0, + 'Syntax::Keyword::Dynamically' => 0, + 'Syntax::Keyword::Match' => '0.06', }, test_requires => { 'Struct::Dumb' => '0.09', @@ -1,5 +1,16 @@ Revision history for Tangence +0.27 2021-10-18: + [CHANGES] + * General code modernisation: + + Use signatures from perl v5.26 + + Use Object::Pad in most classes + + Use Future::AsyncAwait + + Use Syntax::Keyword::Dynamically + + Use Syntax::Keyword::Match in more places + * Rename the memoizing constructors to `->make` to avoid clashing + with the generated ones from Object::Pad + 0.26 2021-09-12 [CHANGES] * General code modernisation: @@ -3,7 +3,6 @@ Build.PL Changes contrib/vim/ftdetect/tangence.vim contrib/vim/syntax/tangence.vim -doc/Tangence.txt lib/Tangence.pm lib/Tangence/Class.pm lib/Tangence/Client.pm @@ -27,7 +26,6 @@ lib/Tangence/Server/Context.pm lib/Tangence/Stream.pm lib/Tangence/Struct.pm lib/Tangence/Type.pm -lib/Tangence/Type/Primitive.pm lib/Tangence/Types.pm LICENSE MANIFEST This list of files @@ -25,12 +25,16 @@ "Exporter" : "5.57", "Feature::Compat::Try" : "0", "Future" : "0.36", + "Future::AsyncAwait" : "0.47", "List::Util" : "1.29", + "Object::Pad" : "0.51", "Parser::MGC" : "0.04", "Struct::Dumb" : "0", "Sub::Util" : "1.40", - "Syntax::Keyword::Match" : "0", - "perl" : "5.014" + "Syntax::Keyword::Dynamically" : "0", + "Syntax::Keyword::Match" : "0.06", + "experimental" : "0", + "perl" : "5.026" } }, "test" : { @@ -48,103 +52,99 @@ "provides" : { "Tangence" : { "file" : "lib/Tangence.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Class" : { "file" : "lib/Tangence/Class.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Client" : { "file" : "lib/Tangence/Client.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Compiler::Parser" : { "file" : "lib/Tangence/Compiler/Parser.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Constants" : { "file" : "lib/Tangence/Constants.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Message" : { "file" : "lib/Tangence/Message.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Meta::Argument" : { "file" : "lib/Tangence/Meta/Argument.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Meta::Class" : { "file" : "lib/Tangence/Meta/Class.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Meta::Event" : { "file" : "lib/Tangence/Meta/Event.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Meta::Field" : { "file" : "lib/Tangence/Meta/Field.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Meta::Method" : { "file" : "lib/Tangence/Meta/Method.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Meta::Property" : { "file" : "lib/Tangence/Meta/Property.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Meta::Struct" : { "file" : "lib/Tangence/Meta/Struct.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Meta::Type" : { "file" : "lib/Tangence/Meta/Type.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Object" : { "file" : "lib/Tangence/Object.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::ObjectProxy" : { "file" : "lib/Tangence/ObjectProxy.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Property" : { "file" : "lib/Tangence/Property.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Registry" : { "file" : "lib/Tangence/Registry.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Server" : { "file" : "lib/Tangence/Server.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Server::Context" : { "file" : "lib/Tangence/Server/Context.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Stream" : { "file" : "lib/Tangence/Stream.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Struct" : { "file" : "lib/Tangence/Struct.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Type" : { "file" : "lib/Tangence/Type.pm", - "version" : "0.26" - }, - "Tangence::Type::Primitive" : { - "file" : "lib/Tangence/Type/Primitive.pm", - "version" : "0.26" + "version" : "0.27" }, "Tangence::Types" : { "file" : "lib/Tangence/Types.pm", - "version" : "0.26" + "version" : "0.27" } }, "release_status" : "stable", @@ -153,6 +153,6 @@ "http://dev.perl.org/licenses/" ] }, - "version" : "0.26", + "version" : "0.27", "x_serialization_backend" : "JSON::PP version 4.05" } @@ -22,91 +22,92 @@ name: Tangence provides: Tangence: file: lib/Tangence.pm - version: '0.26' + version: '0.27' Tangence::Class: file: lib/Tangence/Class.pm - version: '0.26' + version: '0.27' Tangence::Client: file: lib/Tangence/Client.pm - version: '0.26' + version: '0.27' Tangence::Compiler::Parser: file: lib/Tangence/Compiler/Parser.pm - version: '0.26' + version: '0.27' Tangence::Constants: file: lib/Tangence/Constants.pm - version: '0.26' + version: '0.27' Tangence::Message: file: lib/Tangence/Message.pm - version: '0.26' + version: '0.27' Tangence::Meta::Argument: file: lib/Tangence/Meta/Argument.pm - version: '0.26' + version: '0.27' Tangence::Meta::Class: file: lib/Tangence/Meta/Class.pm - version: '0.26' + version: '0.27' Tangence::Meta::Event: file: lib/Tangence/Meta/Event.pm - version: '0.26' + version: '0.27' Tangence::Meta::Field: file: lib/Tangence/Meta/Field.pm - version: '0.26' + version: '0.27' Tangence::Meta::Method: file: lib/Tangence/Meta/Method.pm - version: '0.26' + version: '0.27' Tangence::Meta::Property: file: lib/Tangence/Meta/Property.pm - version: '0.26' + version: '0.27' Tangence::Meta::Struct: file: lib/Tangence/Meta/Struct.pm - version: '0.26' + version: '0.27' Tangence::Meta::Type: file: lib/Tangence/Meta/Type.pm - version: '0.26' + version: '0.27' Tangence::Object: file: lib/Tangence/Object.pm - version: '0.26' + version: '0.27' Tangence::ObjectProxy: file: lib/Tangence/ObjectProxy.pm - version: '0.26' + version: '0.27' Tangence::Property: file: lib/Tangence/Property.pm - version: '0.26' + version: '0.27' Tangence::Registry: file: lib/Tangence/Registry.pm - version: '0.26' + version: '0.27' Tangence::Server: file: lib/Tangence/Server.pm - version: '0.26' + version: '0.27' Tangence::Server::Context: file: lib/Tangence/Server/Context.pm - version: '0.26' + version: '0.27' Tangence::Stream: file: lib/Tangence/Stream.pm - version: '0.26' + version: '0.27' Tangence::Struct: file: lib/Tangence/Struct.pm - version: '0.26' + version: '0.27' Tangence::Type: file: lib/Tangence/Type.pm - version: '0.26' - Tangence::Type::Primitive: - file: lib/Tangence/Type/Primitive.pm - version: '0.26' + version: '0.27' Tangence::Types: file: lib/Tangence/Types.pm - version: '0.26' + version: '0.27' requires: Encode: '0' Exporter: '5.57' Feature::Compat::Try: '0' Future: '0.36' + Future::AsyncAwait: '0.47' List::Util: '1.29' + Object::Pad: '0.51' Parser::MGC: '0.04' Struct::Dumb: '0' Sub::Util: '1.40' - Syntax::Keyword::Match: '0' - perl: '5.014' + Syntax::Keyword::Dynamically: '0' + Syntax::Keyword::Match: '0.06' + experimental: '0' + perl: '5.026' resources: license: http://dev.perl.org/licenses/ -version: '0.26' +version: '0.27' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/doc/Tangence.txt b/doc/Tangence.txt deleted file mode 100644 index 205744a..0000000 --- a/doc/Tangence.txt +++ /dev/null @@ -1,819 +0,0 @@ -An overview of Tangence -======================= - -Tangence is all of the following: - - 1. A single server/multiple client protocol for sharing information - about objects. - - 2. A data model - it defines the types of values that are transmitted - between the server and clients. - - 3. An object model - it defines the abstract look-and-feel of objects - that are visible in the server end, and the proxies to them that - exist in the client ends. - - 4. A wire protocol - it defines the bits down the wire of some stream. - - 5. A collection of Perl modules (a Perl distribution) which implements - all of the above. - -These writings may sometimes suffer the "Java problem"; the problem of -the same name being applied to too many different concepts. I'll try to -make the context or wording clear to minimise confusions. - - -1. Server/Client ----------------- - -In a Tangence system, one program is distinct in being the server. It is -the program that hosts the actual objects being considered. It is also -the program that holds the networking socket to which the clients -connect. - -The other programs are all clients, which connect to the server. While -each client is notionally distinct, they all share access to the same -objects within the server. The clients are not directly aware of each -other's existence, though each one's effects on the system may be -visible to the others as a result of calling methods or altering -properties on the objects. Internally, the clients will use proxy objects -through which to access the objects in the server. There will be a -one-to-one correspondance between server objects and client proxies. Not -every server object needs to have a corresponding proxy in every client - -proxies are created lazily when they are required. - - -2. Data Model -------------- - -Whenever a value is sent across the connection between the server and a -client, that value has a fixed type. The underlying streaming layer -recognises the following fundamental types of values. Each type has a -string to identify call it, called the signature. These are used by -introspection data; see later. - - * Booleans - - Uses the type signature "bool". - - * Integers, both signed and unsigned, in 8, 16, 32 and 64bit lengths - - An integer of unspecified size uses the type signature "int". - Specific sized integers use the type signatures - "s8", "s16", "s32", "s64", "u8", "u16", "u32", "u64" - - * Floating-point numbers, in 16, 32 and 64bit lengths - - A float of unspecified size uses the type signature "float". - Specific sized floats use the type signatures - "float16", "float32", "float64" - - Note that the Intel-specific 80bit "extended double" format is not - supported - - * Unicode strings - - Uses the type signature "str". - - * References to Tangence objects - - Uses the type signature "obj". - - * Lists of values - - Uses the type signature "list(T)" where T is the type signature of its - element type. - - * Dictionaries of (string) named keys to values - - Uses the type signature "dict(T)" where T is the type signature of its - element type. - - * Structured records of values - - Uses a type signature giving the name of the structure type. - - * For type signatures, there is also the type of "any", which allows any - type. - -As Tangence is primarily an interprocess-communication layer, its main -focus is that of communication. The Data Model applies transiently, to -data as it is in transit between the server and a client. A consequence -here is that it only considers the surface value of the types of data, -rather than any deeper significance. It does not preserve self-referential -data, nor can it cope with cyclic structures. More complex shaped data -should be represented by real Tangence objects. - - -3. Object Model ---------------- - -In Tangence, the primary item of interaction is an object. Tangence -objects exist in the server, most likely bearing at least some -relationship to some native objects in the server implementation (though -if and when the occasion ever arises that a C program can host a Tangence -server, obviously this association will be somewhat looser). - -In the server, two special objects exist - one is the Root object, the -other is the Repository. These are the only two well-known objects that -the client knows always exist. All the other objects are initially -accessed via these. - -The client(s) interact with the server almost entirely by performing -operations on objects. When the client connects to the server, two special -object proxies are constructed in the client, to represent the Root and -Repository objects. These are the base through which all the other -interactions are performed. Other object proxies may only be obtained by -the return values of methods on existing objects, arguments passed in -events from them, or retrieved as the value of properties on objects. - -Each object is an instance of some particular class. The class provides -all of the typing information for that instance. Principly, that class -defines a name, and the collection of methods, events, and properties that -exist on instances of that class. Each class may also name other classes -as parents; recursively merging the interface of all those named. - -Tangence concerns itself with the interface of and ways to interact with -the objects in the server, and not with any ways in which the objects -themselves are actually implemented. The class inheritance therefore only -applies to the interface, and does not directly relate to any -implementation behaviour the server might implement. - -3.1. Methods - -Each object class may define named methods that clients can invoke on -objects in the server. Each method has: - - + a name - + argument types - + a return type - -The arguments to a method are positional. The return is a single value -(not a list of values, such as Perl could represent). - -Methods on objects in the server may be invoked by clients. Once a -method is invoked by a client, the client must wait until it returns -before it can send any other request to the server. - -3.2 Events - -Each object class may define named events that objects may emit. Each -method has: - - + a name - + argument types - -Like methods, the arguments to an event are positional. - -Events do not have return types, as they are simple notifications from the -server to the client, to inform them that some event happened. Clients are -not automatically informed of every event on every object. Instead, the -client must specifically register interest in specific events on specific -objects. - -3.3 Properties - -Each object class may define named properties that the object has. Each -object in the class will have a value for the property. Each property has: - - + a name - + a dimension - scalar, queue, array, hash or object set - + a type - + a boolean indicating if it is "smashed" - -Properties do not have arguments. A client can request the current value -of a property on an object, or set a new value. It can also register an -interest in the property, where the server will inform the client of -changes to the value. - -Each property has a dimension; one of scalar, queue, array, hash, or object -set. The behaviour of each type of property is: - -3.3.1 Scalar Properties - -The property is a single atomic scalar. It is set atomically by the -server, and may be queried. - -3.3.2 Queue and Array Properties - -The property is a contiguous array of individual elements. Each element is -indexed by a non-negative integer. The property type gives the type of each -element in the array. These properties differ in the types of operations they -can support. Queues do not support splice or move operations, arrays do. - -3.3.3 Hash Properties - -The property is an association between string and values. Each element is -uniquely indexed by a null-terminated string. The property type gives the -type of each element in the hash. The elements do not have an inherent -ordering and are indexed by unique strings. - -3.3.4 Object Set Properties - -The property is an unordered collection of Tangence objects. - -Scalar properties have a single atomic value. If it changes, the client is -informed of the entire new value, even if its type indicates it to be a -list or dictionary type. For non-scalar properties, the value of each -element in the collection is set individually by the server. Elements can -be changed, added or removed. Changes to individual elements can be sent -to the clients independently of the others. - -Certain properties may be deemed by the application to be important enough -for all clients to be aware of all of the time (such as a name or other -key item of information). These properties are called "smashed -properties". When the server first sends a new object to a client, the -object construction message will also contain initial values of these -properties. The client will be automatically informed of any changes to -these properties when they change, as if the client had specifically -requested to be informed. When the object is sent to a new client, it is -said to be "smashed"; the initial values of these automatic properties are -called "smash values". - -[There are issues here that need resolving to move Tangence out from -being Perl-specific into a more general-purpose layer - more on this in -a later email]. - - -4. Wire Protocol ----------------- - -The wire protocol used by Tangence operates over a reliable stream. This -stream may be provided by a TCP socket, UNIX local socket, or even the -STDIN/STDOUT pipe pair of an SSH connection. - -The following message descriptions all use the symbolic constant names -from the Tangence::Constants perl module, to be more readable. - -4.1. Messages - -At its lowest level, the wire protocol consists of a pair of endpoints to -the stream, each sending and receiving messages to its peer. The protocol -at this level is symmetric between the client and the server. It consists -of messages that are either reqests or responses. - -An endpoint sends a request, which the peer must then respond to. Each -request has exactly one response. The requests and responses are paired -sequentially in a pipeline fashion. - -The two endpoints are distinct from each other, in that there is no -requirement for a peer to respond to an outstanding request it has -received before sending a new request of its own. There is also no -requirement to wait on the response to a request it has sent, before -sending another. - -The basic message format is a binary exchange of messages in the following -format: - - Code: 1 byte integer - Length: 4 bytes integer, big-endian - Payload: n bytes - -The code is a single byte which defines the message type. The collection -of message types is given below. The length is a big-endian 4 byte integer -which gives the size of the message payload, excluding this header. Thus, -the length of the entire message will always be 5 bytes more. The data -payload of the message is encoded in the data serialisation scheme given -below. Each argument to the message is encoded as a single serialisation -item. For message types with a variable number of arguments, the length of -the message itself defines the number of arguments given. - -The stream protocol is designed to be used in situations where the CPU -power of each endpoint is high, but the connection in between may have -high latency, or low bandwidth. It is therefore optimised in favour of -roundtrips and byte count overhead, at the expense of processing power -needed to encode or decode it. One consequence here is that no attempt is -made to align multi-byte values. - -4.2. Data Serialisation - -The data serialisation format applies recursively down a data structure -tree. Each node in structure is either a string, an object reference, or -a list or dictionary of other values. The serialised bytes encode the tree -structure recursively. Other types of entry also exist in the serialised -stream, which carry metadata about the types, such as object classes and -instances. - -The encoding of each node in the data structure consists of a type, a -size, and the actual data payload. The type and size of a node are encoded -in its leader byte (or bytes). The top three bits of the first byte -determines the type: - - Type Bits Description - - DATA_NUMBER 0 0 0 t t t t t numeric - where 'ttttt' gives the number subtype - - DATA_STRING 0 0 1 s s s s s string - DATA_LIST 0 1 0 s s s s s list of values - DATA_DICT 0 1 1 s s s s s dictionary of string->value - DATA_OBJECT 1 0 0 s s s s s Tangence object reference - DATA_RECORD 1 0 1 s s s s s structured record - where 'sssss' gives the size - - DATA_META 1 1 1 n n n n n - where 'nnnnn' gives the metadata type - -For numbers, the lower five bits encode the numeric type, which defines -how many more bytes will be used - - Subtype Subtype bits Extra bytes Description - - DATANUM_BOOLFALSE 0 0 0 0 0 0 Boolean false - DATANUM_BOOLTRUE 0 0 0 0 1 0 Boolean true - DATANUM_UINT8 0 0 0 1 0 1 Unsigned 8bit - DATANUM_SINT8 0 0 0 1 1 1 Signed 8bit - DATANUM_UINT16 0 0 1 0 0 2 Unsigned 16bit - DATANUM_SINT16 0 0 1 0 1 2 Signed 16bit - DATANUM_UINT32 0 0 1 1 0 4 Unsigned 32bit - DATANUM_SINT32 0 0 1 1 1 4 Signed 32bit - DATANUM_UINT64 0 1 0 0 0 8 Unsigned 64bit - DATANUM_SINT64 0 1 0 0 1 8 Signed 64bit - DATANUM_FLOAT16 1 0 0 0 0 2 Floating 16bit - DATANUM_FLOAT32 1 0 0 0 1 4 Floating 32bit - DATANUM_FLOAT64 1 0 0 1 0 8 Floating 64bit - -All multi-byte integers are always stored in big-endian form. - -Floating-point values are stored in IEEE 754 form, as three bitfields -containing sign, exponent and mantissa. The sign always has one bit, clear for -positive, set for negative. The exponent and mantissa have the following sizes -and bias. - - Subtype Exponent Bias Mantissa - - DATANUM_FLOAT16 5 bits +15 10 bits - DATANUM_FLOAT32 8 bits +127 23 bits - DATANUM_FLOAT64 11 bits +1023 52 bits - -Infinities and Not-a-Number values are represented by the exponent having its -maximum allowed value. If the mantissa is zero this represents an infinity of -the given sign, and if the mantissa is non-zero, it is a not-a-number value. -For canonical identity, the non-zero mantissa should have only its top bit -set, and the sign bit should be clear. - - Subtype Exponent Mantissa - - DATANUM_FLOAT16 31 0 Inf - DATANUM_FLOAT16 31 1 << 9 NaN - - DATANUM_FLOAT32 255 0 Inf - DATANUM_FLOAT32 255 1 << 22 NaN - - DATANUM_FLOAT64 1023 0 Inf - DATANUM_FLOAT64 1023 1 << 51 NaN - -For string, list, dict and object types, the lower five bits give a -number, 0 to 31, which helps encode the size. For items of size 30 or -below, this size is encoded directly. Where the size is 31 or more, the -number 31 is encoded, and the actual size follows this leading byte. For -sizes 31 to 127, the next byte encodes it. For sizes 128 or above, the -next 4 bytes encode it in big-endian format, with the top bit set. Sizes -above 2^31 cannot be encoded. - -Following the leader are bytes encoding the data. The exact meaning of the -size depends on the type of the node. - -For strings, the size gives the number of bytes in the string. These -bytes then follow the leader. - -For lists, the size gives the number of elements in the list. Following -the leader will be this number of data serialisations, one per list -element. - -For dictionaries, this size gives the number of key/value pairs. Following -the leader will be this number of key/value pairs. Each pair consists of a -string for the key name, then a data serialisation for the value. - -For objects, the size gives the number of bytes in the object's ID number, -followed by a big-endian encoding of the object's ID number. Currently, -this will always be a 4 byte number. - -For structured records, the size gives the count of serialied data members for -the record. Following the leader will be the ID number of the structure type -as an int, followed by the given number of data members, in the order that the -structure type declares. The field names are not serialised, as they can be -inferred from the structure type's definition. - -Meta-data items may be embedded within a data stream in order to create -the object classes and instances which it contains. These metadata items -do not count towards the overall size of a collection value. - -Meta-data operations encode a subtype number, rather than a size, in the -bottom five bits. - - Metadata type Bits Description - - DATAMETA_CONSTRUCT 1 1 1 0 0 0 0 1 Construct an object - DATAMETA_CLASS 1 1 1 0 0 0 1 0 Create a new object class - DATAMETA_STRUCT 1 1 1 0 0 0 1 1 Create a new record struct type - -Following each metadata item is an encoding of its arguments. - -DATAMETA_CONSTRUCT: - Object ID: int - Class ID: int - Smash values: 0 or more bytes, encoded per type (in a list container) - - If the object class defines smash properties, the construct message will - also contain the values for the smash properties. These will be sent in - a list, one value per property, in the same order as the object class's - schema defines the smash keys. Each will be encoded as per its declared - type. - -DATAMETA_CLASS: - Class name: string - Class ID: int - Class: struct of type Tangence.Class - Smash keys: data encoded (list) - - The class definition itself will be encoded as a Tangence.Class structure, - containing nested Tangence.Method, Tangence.Event and Tangence.Property - elements. If the class declares any superclasses, these will be sent in - other DATAMETA_CLASS metadata items before this one. - - The smash keys will be encoded as a possibly-empty list of strings. - -DATAMETA_STRUCT: - Struct name: string - Struct ID: int - Field names: list of strings - Field types: list of strings - -4.3. Message Types - -Each of the messages defines the layout of its data payload. Some messages -pass a fixed number of items, some have a variable number of items in the -last position. For these messages, no explicit encoding of the size is -given. Instead, the data payload area is packed with as many data -encodings as are required. The receiver should use the size of the -containing message to know when all the items have been unpacked. - -The following request types are defined. Any message may be responded to -by MSG_ERROR in case of an error, so this response type is not listed. -Some of these messages are sent from the client to the server (C->S), -others are sent from the server to client (S->C) - -MSG_CALL (C->S) (0x01) - INT object ID - STRING method name - data... arguments - - Responses: MSG_RESULT - - Calls the named method on the given object. - -MSG_SUBSCRIBE (C->S) (0x02) - INT object ID - STRING event name - - Responses: MSG_SUBSCRIBED - - Subscribes the client to be informed of the event on given object. - -MSG_UNSUBSCRIBE (C->S) (0x03) - INT object ID - STRING event name - - Responses: MSG_OK - - Cancels an event subscription. - -MSG_EVENT (S->C) (0x04) - INT object ID - STRING event name - data... arguments - - Responses: MSG_OK - - Informs the client that the event has occured. - -MSG_GETPROP (C->S) (0x05) - INT object ID - STRING property name - - Responses: MSG_RESULT - - Requests the current value of the property - -MSG_SETPROP (C->S) (0x06) - INT object ID - STRING property name - data new value - - Responses: MSG_OK - - Sets the new value of the property - -MSG_WATCH (C->S) (0x07) - INT object ID - STRING property name - BOOL want initial? - - Responses: MSG_WATCHING - - Requests to be informed of changes to the property value. If the - boolean 'want initial' value is true, the client will be sent an - initial MSG_CHANGE message for the current value of the property. - -MSG_UNWATCH (C->S) (0x08) - INT object ID - STRING property name - - Responses: MSG_OK - - Cancels a request to watch a property - -MSG_UPDATE (S->C) (0x09) - INT object ID - STRING property name - U8 change type - data... change value - - Responses: MSG_OK - - Informs the client that the property value has now changed. The - type of change is given by the change type argument, and defines the - data layout in the value arguments. The exact meaning of the operation - depends on the dimension of the property it acts on. - - For DIM_SCALAR: - - CHANGE_SET: - data new value - - Sets the new value of the property. - - For DIM_HASH: - CHANGE_SET: - DICT new value - - Sets the new value of the property. - - CHANGE_ADD: - STRING key - data value - - Adds a new element to the hash. - - CHANGE_DEL: - STRING key - - Deletes an element from the hash. - - For DIM_QUEUE: - CHANGE_SET: - LIST new value - - Sets the new value of the property. - - CHANGE_PUSH: - data... additional values - - Appends the additional values to the end of the queue. - - CHANGE_SHIFT: - INT number of elements - - Removes a number of leading elements from the beginning of the - queue. - - For DIM_ARRAY: - CHANGE_SET: - LIST new value - - Sets the new value of the property. - - CHANGE_PUSH: - data... additional values - - Appends the additional values to the end of the array. - - CHANGE_SHIFT: - INT number of elements - - Removes a number of leading elements from the beginning of the - array. - - CHANGE_SPLICE: - INT start - INT count - data... new elements - - Replaces the given range of the array with the new elements given. - The new list of values may be a different length to the replaced - section - in this case, subsequent elements will be shifted up or - down accordingly. - - CHANGE_MOVE: - INT index - INT delta - - Moves the item currently at the index forward a (signed) delta amount, - such that its new index becomes index+delta. The items inbetween the old - and new index will be moved up or down as appropriate. - - For DIM_OBJSET: - CHANGE_SET: - LIST objects - - Sets the new value for the property. Will be given a list of - Tangence object references. - - CHANGE_ADD: - OBJECT new object - - Adds the given object to the set - - CHANGE_DEL: - STRING object ID - - Removes the object of the given ID from the set. - -MSG_DESTROY (S->C) (0x0a) - INT object ID - - Responses: MSG_OK - - Informs the client that the object is due for destruction in - the server. Upon receipt of this message the client should destroy - any remaining references it has to the object. After it has sent the - MSG_OK response, it will not be allowed to invoke any methods, - subscribe to any events, nor interact with any properties on - the object. Any existing event subscriptions or property - watches will have been removed by the server before this message is - sent. - -MSG_GETPROPELEM (C->S) (0x0b) - INT object ID - STRING property name - INT|STRING element index or key - - Responses: MSG_RESULT - - Requests the current value of a single element in a queue or array - (by element index), or hash (by key name). Cannot be applied to - scalar or objset properties. - -MSG_WATCH_CUSR (C->S) (0x0c) - INT object ID - STRING property name - INT from - - Responses: MSG_WATCHING_CUSR - - Similar to MSG_WATCH, requests to be informed of changes to the - property value, which must be a queue property. Creates a new - cursor for the property, beginning at the first index (if - from == 1) or the last (if from == 2). - -MSG_CUSR_NEXT (C->S) (0x0d) - INT cursor ID - INT direction - INT count - - Responses: MSG_CUSR_RESULT - - Requests the next few items from a property cursor. It will yield a - MSG_RESULT message containing up to the given number of items, by - moving forwards (if direction == 1) or backwards (if direction == 2). - If the cursor is already at the edge of the queue then the MSG_RESULT - will contain no extra items. - -MSG_CUSR_DESTROY (C->S) (0x0e) - INT cursor ID - - Informs the server that the client has finished using the cursor, and it - can release any resources attached to it. - -MSG_GETROOT (C->S) (0x40) - data identity - - Responses: MSG_RESULT - - Initial message to be sent by the client to obtain the root object. The - identity may be used to identify this particular client, as part of its - login procedure. The result will contain a single object reference, - being the root object. - -MSG_GETREGISTRY (C->S) (0x41) - [no arguments] - - Responses: MSG_RESULT - - Requests the registry object from the server. The result will contain a - single object reference, being the registry object. - -MSG_INIT (C->S) (0x7f) - INT major version - INT maximal minor version - INT minimal minor version - - Responses: MSG_INITED - - Requests the start of the Tangence stream. This must be the first message - sent by the client. If the server is unwilling to provide a suitable version - it can return MSG_ERROR. Otherwise, the accepted minor is returned in the - MSG_INITED message. - - The version specified by this document is major 0, minor 4. - -The following responses may be sent to a request: - -MSG_OK (0x80) - [no arguments] - - A simple OK message, informing the requester that the operation was - successful, an no error occured. - -MSG_ERROR (0x81) - STRING error message - - An error occured; the text of the message is included. - -MSG_RESULT (0x82) - data... values - - Contains the return value from a method call, a property value, or the - initial root or registry object. - -MSG_SUBSCRIBED (0x83) - [no arguments] - - Informs the client that a MSG_SUBSCRIBE was successful. - -MSG_WATCHING (0x84) - [no arguments] - - Informs the client that a MSG_WATCH was successful. - -MSG_WATCHING_CUSR (0x85) - INT cursor ID - INT first index (inclusive) - INT last index (inclusive) - - Informs the client that a MSG_WATCH_CUSR was successful, and returns - the new cursor ID and the first and last indices inclusive of the queue - it will iterate over. - - ((The reason for using first and last indices inclusively, rather - than yielding the total size of the queue, is that this makes it - easier to support iterating over hashes in a future version)) - -MSG_CUSR_RESULT (0x86) - INT first item index - data... values - - Contains the return value from a MSG_CUSR_NEXT call. Gives the index - of the first item in the returned result, and the requested items. - There may fewer items than requested, if the edge of the property - value was reached. - -MSG_INITED (0xff) - INT major version - INT minor version - - Informs the client that the initial MSG_INIT was successful, and what - minor version was accepted. - -4.4 Built-in Structure Types - -The following structure types are built-in, with the given structure ID -numbers. They can be assumed pre-knowledge by both ends of the stream and do -not need serialising by DATAMETA_STRUCT records. - -4.4.1 Tangence.Class - - Structure ID: 1 - Fields: - methods : dict(any) - events : dict(any) - properties : dict(any) - superclasses : list(str) - -4.4.2 Tangence.Method - - Structure ID: 2 - Fields: - arguments : list(str) - returns : str - -4.4.3 Tangence.Event - - Structure ID: 3 - Fields: - arguments : list(str) - -4.4.4 Tangence.Property - - Structure ID: 4 - Fields: - dimension : int - type : str - smashed : bool - --- -Paul "LeoNerd" Evans - -leonerd@leonerd.org.uk -http://www.leonerd.org.uk/ diff --git a/lib/Tangence.pm b/lib/Tangence.pm index d5c3edf..6138354 100644 --- a/lib/Tangence.pm +++ b/lib/Tangence.pm @@ -3,9 +3,9 @@ # # (C) Paul Evans, 2010 -- leonerd@leonerd.org.uk -package Tangence 0.26; +package Tangence 0.27; -use v5.14; +use v5.26; use warnings; # This package contains no code other than a declaration of the version. diff --git a/lib/Tangence/Class.pm b/lib/Tangence/Class.pm index 4bb1a7f..c1e2347 100644 --- a/lib/Tangence/Class.pm +++ b/lib/Tangence/Class.pm @@ -1,13 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2010-2020 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk -package Tangence::Class 0.26; +use v5.26; +use Object::Pad 0.41; -use v5.14; -use warnings; -use base qw( Tangence::Meta::Class ); +package Tangence::Class 0.27; +class Tangence::Class isa Tangence::Meta::Class; use Tangence::Constants; @@ -21,73 +21,66 @@ use Carp; use Sub::Util 1.40 qw( set_subname ); -our %metas; # cache one per class, keyed by _Tangence_ class name +our %CLASSES; # cache one per class, keyed by _Tangence_ class name -sub new +sub make ( $class, %args ) { - my $class = shift; - my %args = @_; my $name = $args{name}; - return $metas{$name} ||= $class->SUPER::new( @_ ); + return $CLASSES{$name} //= $class->new( %args ); } -sub _new_type +sub _new_type ( $sig ) { - my ( $sig ) = @_; - return Tangence::Type->new_from_sig( $sig ); + return Tangence::Type->make_from_sig( $sig ); } -sub declare +sub declare ( $class, $perlname, %args ) { - my $class = shift; - my ( $perlname, %args ) = @_; - ( my $name = $perlname ) =~ s{::}{.}g; - my $self; - if( exists $metas{$name} ) { - $self = $metas{$name}; - local $metas{$name}; - - my $newself = $class->new( name => $name ); - - %$self = %$newself; - } - else { - $self = $class->new( name => $name ); + if( exists $CLASSES{$name} ) { + croak "Cannot re-declare $name"; } + my $self = $class->make( name => $name ); + my %methods; foreach ( keys %{ $args{methods} } ) { + my %params = %{ $args{methods}{$_} }; $methods{$_} = Tangence::Meta::Method->new( + class => $self, name => $_, - %{ $args{methods}{$_} }, arguments => [ map { Tangence::Meta::Argument->new( name => $_->[0], type => _new_type( $_->[1] ) ) - } @{ $args{methods}{$_}{args} } ], - ret => _new_type( $args{methods}{$_}{ret} ), + } @{ delete $params{args} } ], + ret => _new_type( delete $params{ret} ), + %params, ); } my %events; foreach ( keys %{ $args{events} } ) { + my %params = %{ $args{events}{$_} }; $events{$_} = Tangence::Meta::Event->new( + class => $self, name => $_, - %{ $args{events}{$_} }, arguments => [ map { Tangence::Meta::Argument->new( name => $_->[0], type => _new_type( $_->[1] ) ) - } @{ $args{events}{$_}{args} } ], + } @{ delete $params{args} } ], + %params, ); } my %properties; foreach ( keys %{ $args{props} } ) { + my %params = %{ $args{props}{$_} }; $properties{$_} = Tangence::Property->new( + class => $self, name => $_, - %{ $args{props}{$_} }, - dimension => $args{props}{$_}{dim} || DIM_SCALAR, - type => _new_type( $args{props}{$_}{type} ), + dimension => ( delete $params{dim} ) || DIM_SCALAR, + type => _new_type( delete $params{type} ), + %params, ); } @@ -104,9 +97,8 @@ sub declare ); } -sub define +method define { - my $self = shift; $self->SUPER::define( @_ ); my $class = $self->perlname; @@ -124,21 +116,15 @@ sub define } } -sub for_name +sub for_name ( $class, $name ) { - my $class = shift; - my ( $name ) = @_; - - return $metas{$name} || croak "Unknown Tangence::Class for '$name'"; + return $CLASSES{$name} // croak "Unknown Tangence::Class for '$name'"; } -sub for_perlname +sub for_perlname ( $class, $perlname ) { - my $class = shift; - my ( $perlname ) = @_; - ( my $name = $perlname ) =~ s{::}{.}g; - return $metas{$name} || croak "Unknown Tangence::Class for '$perlname'"; + return $CLASSES{$name} // croak "Unknown Tangence::Class for '$perlname'"; } sub superclasses @@ -154,31 +140,26 @@ sub superclasses return @supers; } -sub method +method method ( $name ) { - my $self = shift; - my ( $name ) = @_; return $self->methods->{$name}; } -sub event +method event ( $name ) { - my $self = shift; - my ( $name ) = @_; return $self->events->{$name}; } -sub property +method property ( $name ) { - my $self = shift; - my ( $name ) = @_; return $self->properties->{$name}; } -sub smashkeys +has $smashkeys; + +method smashkeys { - my $self = shift; - return $self->{smashkeys} ||= do { + return $smashkeys //= do { my %smash; $smash{$_->name} = 1 for grep { $_->smashed } values %{ $self->properties }; $Tangence::Message::SORT_HASH_KEYS ? [ sort keys %smash ] : [ keys %smash ]; diff --git a/lib/Tangence/Client.pm b/lib/Tangence/Client.pm index b74d93f..ebc458b 100644 --- a/lib/Tangence/Client.pm +++ b/lib/Tangence/Client.pm @@ -1,12 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2010-2020 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk -package Tangence::Client 0.26; +package Tangence::Client 0.27; -use v5.14; +use v5.26; use warnings; +use experimental 'signatures'; use base qw( Tangence::Stream ); @@ -207,11 +208,8 @@ case the application requires features in a newer version than that. =cut -sub tangence_connected +sub tangence_connected ( $self, %args ) { - my $self = shift; - my %args = @_; - my $version_minor_min = max( VERSION_MINOR_MIN, $args{version_minor_min} || 0 ); $self->request( @@ -242,11 +240,8 @@ sub tangence_connected ); } -sub tangence_initialised +sub tangence_initialised ( $self, %args ) { - my $self = shift; - my %args = @_; - my $request = Tangence::Message->new( $self, MSG_GETROOT ); TYPE_ANY->pack_value( $request, $self->identity ); @@ -282,11 +277,8 @@ sub tangence_initialised )->retain; } -sub handle_request_EVENT +sub handle_request_EVENT ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $objid = $message->unpack_int(); $self->respond( $token, Tangence::Message->new( $self, MSG_OK ) ); @@ -296,11 +288,8 @@ sub handle_request_EVENT } } -sub handle_request_UPDATE +sub handle_request_UPDATE ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $objid = $message->unpack_int(); $self->respond( $token, Tangence::Message->new( $self, MSG_OK ) ); @@ -310,11 +299,8 @@ sub handle_request_UPDATE } } -sub handle_request_DESTROY +sub handle_request_DESTROY ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $objid = $message->unpack_int(); if( my $obj = $self->objectproxies->{$objid} ) { @@ -325,21 +311,15 @@ sub handle_request_DESTROY $self->respond( $token, Tangence::Message->new( $self, MSG_OK ) ); } -sub get_by_id +sub get_by_id ( $self, $id ) { - my $self = shift; - my ( $id ) = @_; - return $self->objectproxies->{$id} if exists $self->objectproxies->{$id}; croak "Have no proxy of object id $id"; } -sub make_proxy +sub make_proxy ( $self, $id, $classname, $smashdata ) { - my $self = shift; - my ( $id, $classname, $smashdata ) = @_; - if( exists $self->objectproxies->{$id} ) { croak "Already have an object id $id"; } diff --git a/lib/Tangence/Compiler/Parser.pm b/lib/Tangence/Compiler/Parser.pm index 8ba42dd..837a2b5 100644 --- a/lib/Tangence/Compiler/Parser.pm +++ b/lib/Tangence/Compiler/Parser.pm @@ -1,14 +1,15 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2011-2017 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk -package Tangence::Compiler::Parser 0.26; +use v5.26; +use Object::Pad 0.41; -use v5.14; -use warnings; -use base qw( Parser::MGC ); +package Tangence::Compiler::Parser 0.27; +class Tangence::Compiler::Parser isa Parser::MGC; +use Syntax::Keyword::Dynamically; use Syntax::Keyword::Match; use File::Basename qw( dirname ); @@ -68,11 +69,17 @@ The contents of the struct block will be a list of C<field> declarations. =cut -sub parse -{ - my $self = shift; +has $_package; + +# Parser::MGC version 0.20 adds this method. Before then, this workaround is +# known to be safe +if( $Parser::MGC::VERSION < 0.20 ) { + *filename = sub ( $self ) { $self->{filename} }; +} - local $self->{package} = \my %package; +method parse +{ + dynamically $_package = \my %package; while( !$self->at_eos ) { match( $self->token_kw(qw( class struct include )) : eq ) { @@ -99,7 +106,7 @@ sub parse $self->scope_of( '{', sub { $self->parse_structblock( $struct ) }, '}' ), } case( 'include' ) { - my $filename = dirname($self->{filename}) . "/" . $self->token_string; + my $filename = dirname($self->filename) . "/" . $self->token_string; my $subparser = (ref $self)->new; my $included = $subparser->from_file( $filename ); @@ -154,11 +161,8 @@ An C<isa> declaration declares a superclass of the class, by its name (C) =cut -sub parse_classblock +method parse_classblock ( $class ) { - my $self = shift; - my ( $class ) = @_; - my %methods; my %events; my %properties; @@ -239,7 +243,7 @@ sub parse_classblock case( 'isa' ) { my $supername = $self->token_ident; - my $super = $self->{package}{$supername} or + my $super = $_package->{$supername} or $self->fail( "Unrecognised superclass $supername" ); push @superclasses, $super; @@ -257,9 +261,8 @@ sub parse_classblock ); } -sub parse_arglist +method parse_arglist { - my $self = shift; return $self->scope_of( "(", sub { $self->list_of( ",", \&parse_arg ) }, @@ -267,9 +270,8 @@ sub parse_arglist ); } -sub parse_arg +method parse_arg { - my $self = shift; my $name; my $type = $self->parse_type; $self->maybe( sub { @@ -278,11 +280,8 @@ sub parse_arg return $self->make_argument( name => $name, type => $type ); } -sub parse_structblock +method parse_structblock ( $struct ) { - my $self = shift; - my ( $struct ) = @_; - my @fields; my %fieldnames; @@ -337,10 +336,8 @@ my @basic_types = qw( any ); -sub parse_type +method parse_type { - my $self = shift; - $self->any_of( sub { my $aggregate = $self->token_kw(qw( list dict )); @@ -370,10 +367,8 @@ my %dimensions = ( objset => DIM_OBJSET, ); -sub parse_dim +method parse_dim { - my $self = shift; - my $dimname = $self->token_kw( keys %dimensions ); return $dimensions{$dimname}; @@ -396,9 +391,8 @@ parser will call C<define> on it. =cut -sub make_class +method make_class { - shift; require Tangence::Meta::Class; return Tangence::Meta::Class->new( @_ ); } @@ -412,9 +406,8 @@ parser will call C<define> on it. =cut -sub make_struct +method make_struct { - shift; require Tangence::Meta::Struct; return Tangence::Meta::Struct->new( @_ ); } @@ -436,23 +429,20 @@ or L<Tangence::Meta::Property> to go in a class. =cut -sub make_method +method make_method { - shift; require Tangence::Meta::Method; return Tangence::Meta::Method->new( @_ ); } -sub make_event +method make_event { - shift; require Tangence::Meta::Event; return Tangence::Meta::Event->new( @_ ); } -sub make_property +method make_property { - shift; require Tangence::Meta::Property; return Tangence::Meta::Property->new( @_ ); } @@ -466,9 +456,8 @@ or event argument. =cut -sub make_argument +method make_argument { - my $self = shift; require Tangence::Meta::Argument; return Tangence::Meta::Argument->new( @_ ); } @@ -481,9 +470,8 @@ Return a new instance of L<Tangence::Meta::Field> to use for a structure type. =cut -sub make_field +method make_field { - my $self = shift; require Tangence::Meta::Field; return Tangence::Meta::Field->new( @_ ); } @@ -501,11 +489,10 @@ aggregate and member type. =cut -sub make_type +method make_type { - my $self = shift; require Tangence::Meta::Type; - return Tangence::Meta::Type->new( @_ ); + return Tangence::Meta::Type->make( @_ ); } =head1 AUTHOR diff --git a/lib/Tangence/Constants.pm b/lib/Tangence/Constants.pm index 3dd3a70..79e4c80 100644 --- a/lib/Tangence/Constants.pm +++ b/lib/Tangence/Constants.pm @@ -3,9 +3,9 @@ # # (C) Paul Evans, 2010-2016 -- leonerd@leonerd.org.uk -package Tangence::Constants 0.26; +package Tangence::Constants 0.27; -use v5.14; +use v5.26; use warnings; use Exporter 'import'; diff --git a/lib/Tangence/Message.pm b/lib/Tangence/Message.pm index 0521415..51c8986 100644 --- a/lib/Tangence/Message.pm +++ b/lib/Tangence/Message.pm @@ -1,12 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2010-2014 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk -package Tangence::Message 0.26; +use v5.26; +use Object::Pad 0.41; -use v5.14; -use warnings; +package Tangence::Message 0.27; +class Tangence::Message; use Carp; @@ -30,86 +31,39 @@ use Scalar::Util qw( weaken blessed ); # true value will sort keys first our $SORT_HASH_KEYS = 0; -sub new -{ - my $class = shift; - my ( $stream, $code, $record ) = @_; - - $record = "" unless defined $record; - - return bless { - stream => $stream, - code => $code, - record => $record, - }, $class; -} - -sub try_new_from_bytes -{ - my $class = shift; - my $stream = shift; - - return undef unless length $_[0] >= 5; - - my ( $code, $len ) = unpack( "CN", $_[0] ); - return 0 unless length $_[0] >= 5 + $len; - - substr( $_[0], 0, 5, "" ); - - my $record = substr( $_[0], 0, $len, "" ); +has $_stream :param :reader; +has $_code :param :reader; +has $_payload :param :reader; - return $class->new( $stream, $code, $record ); -} - -sub stream -{ - my $self = shift; - return $self->{stream}; -} - -sub code +sub BUILDARGS ( $class, $stream, $code, $payload = "" ) { - my $self = shift; - return $self->{code}; + return ( stream => $stream, code => $code, payload => $payload ); } -sub bytes +method _pack_leader ( $type, $num ) { - my $self = shift; - - my $record = $self->{record}; - return pack( "CNa*", $self->{code}, length($record), $record ); -} - -sub _pack_leader -{ - my $self = shift; - my ( $type, $num ) = @_; - if( $num < 0x1f ) { - $self->{record} .= pack( "C", ( $type << 5 ) | $num ); + $_payload .= pack( "C", ( $type << 5 ) | $num ); } elsif( $num < 0x80 ) { - $self->{record} .= pack( "CC", ( $type << 5 ) | 0x1f, $num ); + $_payload .= pack( "CC", ( $type << 5 ) | 0x1f, $num ); } else { - $self->{record} .= pack( "CN", ( $type << 5 ) | 0x1f, $num | 0x80000000 ); + $_payload .= pack( "CN", ( $type << 5 ) | 0x1f, $num | 0x80000000 ); } } -sub _peek_leader_type +method _peek_leader_type { - my $self = shift; - while(1) { - length $self->{record} or croak "Ran out of bytes before finding a leader"; + length $_payload or croak "Ran out of bytes before finding a leader"; - my ( $typenum ) = unpack( "C", $self->{record} ); + my ( $typenum ) = unpack( "C", $_payload ); my $type = $typenum >> 5; return $type unless $type == DATA_META; - substr( $self->{record}, 0, 1, "" ); + substr( $_payload, 0, 1, "" ); my $num = $typenum & 0x1f; if( $num == DATAMETA_CONSTRUCT ) { @@ -127,106 +81,86 @@ sub _peek_leader_type } } -sub _unpack_leader +method _unpack_leader ( $peek = 0 ) { - my $self = shift; - my ( $peek ) = @_; - my $type = $self->_peek_leader_type; - my ( $typenum ) = unpack( "C", $self->{record} ); + my ( $typenum ) = unpack( "C", $_payload ); my $num = $typenum & 0x1f; my $len = 1; if( $num == 0x1f ) { - ( $num ) = unpack( "x C", $self->{record} ); + ( $num ) = unpack( "x C", $_payload ); if( $num < 0x80 ) { $len = 2; } else { - ( $num ) = unpack( "x N", $self->{record} ); + ( $num ) = unpack( "x N", $_payload ); $num &= 0x7fffffff; $len = 5; } } - substr( $self->{record}, 0, $len ) = "" if !$peek; + substr( $_payload, 0, $len ) = "" if !$peek; return $type, $num; } -sub _pack +method _pack ( $s ) { - my $self = shift; - $self->{record} .= $_[0]; + $_payload .= $s; } -sub _unpack +method _unpack ( $num ) { - my $self = shift; - my ( $num ) = @_; - length $self->{record} >= $num or croak "Can't pull $num bytes as there aren't enough"; - return substr( $self->{record}, 0, $num, "" ); + length $_payload >= $num or croak "Can't pull $num bytes as there aren't enough"; + return substr( $_payload, 0, $num, "" ); } -sub pack_bool +method pack_bool ( $d ) { - my $self = shift; - my ( $d ) = @_; TYPE_BOOL->pack_value( $self, $d ); return $self; } -sub unpack_bool +method unpack_bool { - my $self = shift; return TYPE_BOOL->unpack_value( $self ); } -sub pack_int +method pack_int ( $d ) { - my $self = shift; - my ( $d ) = @_; TYPE_INT->pack_value( $self, $d ); return $self; } -sub unpack_int +method unpack_int { - my $self = shift; return TYPE_INT->unpack_value( $self ); } -sub pack_str +method pack_str ( $d ) { - my $self = shift; - my ( $d ) = @_; TYPE_STR->pack_value( $self, $d ); return $self; } -sub unpack_str +method unpack_str { - my $self = shift; return TYPE_STR->unpack_value( $self ); } -sub pack_record +method pack_record ( $rec, $struct = undef ) { - my $self = shift; - my ( $rec, $struct ) = @_; - - my $stream = $self->{stream}; - $struct ||= eval { Tangence::Struct->for_perlname( ref $rec ) } or croak "No struct for " . ref $rec; - $self->packmeta_struct( $struct ) unless $stream->peer_hasstruct->{$struct->perlname}; + $self->packmeta_struct( $struct ) unless $_stream->peer_hasstruct->{$struct->perlname}; my @fields = $struct->fields; $self->_pack_leader( DATA_RECORD, scalar @fields ); - $self->pack_int( $stream->peer_hasstruct->{$struct->perlname}->[1] ); + $self->pack_int( $_stream->peer_hasstruct->{$struct->perlname}->[1] ); foreach my $field ( @fields ) { my $fieldname = $field->name; $field->type->pack_value( $self, $rec->$fieldname ); @@ -235,18 +169,13 @@ sub pack_record return $self; } -sub unpack_record +method unpack_record ( $struct = undef ) { - my $self = shift; - my ( $struct ) = @_; - - my $stream = $self->{stream}; - my ( $type, $num ) = $self->_unpack_leader(); $type == DATA_RECORD or croak "Expected to unpack a record but did not find one"; my $structid = $self->unpack_int(); - my $got_struct = $stream->message_state->{id2struct}{$structid}; + my $got_struct = $_stream->message_state->{id2struct}{$structid}; if( !$struct ) { $struct = $got_struct; } @@ -265,32 +194,27 @@ sub unpack_record return $struct->perlname->new( %values ); } -sub packmeta_construct +method packmeta_construct ( $obj ) { - my $self = shift; - my ( $obj ) = @_; - - my $stream = $self->{stream}; - my $class = $obj->class; my $id = $obj->id; - $self->packmeta_class( $class ) unless $stream->peer_hasclass->{$class->perlname}; + $self->packmeta_class( $class ) unless $_stream->peer_hasclass->{$class->perlname}; my $smashkeys = $class->smashkeys; $self->_pack_leader( DATA_META, DATAMETA_CONSTRUCT ); $self->pack_int( $id ); - $self->pack_int( $stream->peer_hasclass->{$class->perlname}->[2] ); + $self->pack_int( $_stream->peer_hasclass->{$class->perlname}->[2] ); if( @$smashkeys ) { my $smashdata = $obj->smash( $smashkeys ); for my $prop ( @$smashkeys ) { - $stream->_install_watch( $obj, $prop ); + $_stream->_install_watch( $obj, $prop ); } - if( $stream->_ver_can_typed_smash ) { + if( $_stream->_ver_can_typed_smash ) { $self->_pack_leader( DATA_LIST, scalar @$smashkeys ); foreach my $prop ( @$smashkeys ) { $class->property( $prop )->overall_type->pack_value( $self, $smashdata->{$prop} ); @@ -304,26 +228,22 @@ sub packmeta_construct $self->_pack_leader( DATA_LIST, 0 ); } - weaken( my $weakstream = $stream ); - $stream->peer_hasobj->{$id} = $obj->subscribe_event( + weaken( my $weakstream = $_stream ); + $_stream->peer_hasobj->{$id} = $obj->subscribe_event( destroy => sub { $weakstream->object_destroyed( @_ ) if $weakstream }, ); } -sub unpackmeta_construct +method unpackmeta_construct { - my $self = shift; - - my $stream = $self->{stream}; - my $id = $self->unpack_int(); my $classid = $self->unpack_int(); - my $class_perlname = $stream->message_state->{id2class}{$classid}; + my $class_perlname = $_stream->message_state->{id2class}{$classid}; - my ( $class, $smashkeys ) = @{ $stream->peer_hasclass->{$class_perlname} }; + my ( $class, $smashkeys ) = @{ $_stream->peer_hasclass->{$class_perlname} }; my $smasharr; - if( $stream->_ver_can_typed_smash ) { + if( $_stream->_ver_can_typed_smash ) { my ( $type, $num ) = $self->_unpack_leader; $type == DATA_LIST or croak "Expected to unpack a LIST of smashed data"; $num == @$smashkeys or croak "Expected to unpack a LIST of " . ( scalar @$smashkeys ) . " elements"; @@ -339,25 +259,20 @@ sub unpackmeta_construct my $smashdata; $smashdata->{$smashkeys->[$_]} = $smasharr->[$_] for 0 .. $#$smasharr; - $stream->make_proxy( $id, $class_perlname, $smashdata ); + $_stream->make_proxy( $id, $class_perlname, $smashdata ); } -sub packmeta_class +method packmeta_class ( $class ) { - my $self = shift; - my ( $class ) = @_; - - my $stream = $self->{stream}; - my @superclasses = grep { $_->name ne "Tangence.Object" } $class->direct_superclasses; - $stream->peer_hasclass->{$_->perlname} or $self->packmeta_class( $_ ) for @superclasses; + $_stream->peer_hasclass->{$_->perlname} or $self->packmeta_class( $_ ) for @superclasses; $self->_pack_leader( DATA_META, DATAMETA_CLASS ); my $smashkeys = $class->smashkeys; - my $classid = ++$stream->message_state->{next_classid}; + my $classid = ++$_stream->message_state->{next_classid}; $self->pack_str( $class->name ); $self->pack_int( $classid ); @@ -392,15 +307,11 @@ sub packmeta_class TYPE_LIST_STR->pack_value( $self, $smashkeys ); - $stream->peer_hasclass->{$class->perlname} = [ $class, $smashkeys, $classid ]; + $_stream->peer_hasclass->{$class->perlname} = [ $class, $smashkeys, $classid ]; } -sub unpackmeta_class +method unpackmeta_class { - my $self = shift; - - my $stream = $self->{stream}; - my $name = $self->unpack_str(); my $classid = $self->unpack_int(); my $classrec = $self->unpack_record(); @@ -412,11 +323,11 @@ sub unpackmeta_class $a => Tangence::Meta::Method->new( class => $class, name => $a, - ret => $b->returns ? Tangence::Type->new_from_sig( $b->returns ) + ret => $b->returns ? Tangence::Type->make_from_sig( $b->returns ) : undef, arguments => [ map { Tangence::Meta::Argument->new( - type => Tangence::Type->new_from_sig( $_ ), + type => Tangence::Type->make_from_sig( $_ ), ) } @{ $b->arguments } ], ) @@ -430,7 +341,7 @@ sub unpackmeta_class name => $a, arguments => [ map { Tangence::Meta::Argument->new( - type => Tangence::Type->new_from_sig( $_ ), + type => Tangence::Type->make_from_sig( $_ ), ) } @{ $b->arguments } ], ) @@ -445,7 +356,7 @@ sub unpackmeta_class class => $class, name => $a, dimension => $b->dimension, - type => Tangence::Type->new_from_sig( $b->type ), + type => Tangence::Type->make_from_sig( $b->type ), smashed => $b->smashed, ) } %{ $classrec->properties } @@ -454,7 +365,7 @@ sub unpackmeta_class superclasses => do { my @superclasses = map { ( my $perlname = $_ ) =~ s/\./::/g; - $stream->peer_hasclass->{$perlname}->[3] or croak "Unrecognised class $perlname"; + $_stream->peer_hasclass->{$perlname}->[3] or croak "Unrecognised class $perlname"; } @{ $classrec->superclasses }; @superclasses ? \@superclasses : [ Tangence::Class->for_name( "Tangence.Object" ) ] @@ -465,44 +376,35 @@ sub unpackmeta_class my $smashkeys = TYPE_LIST_STR->unpack_value( $self ); - $stream->peer_hasclass->{$perlname} = [ $class, $smashkeys, $classid, $class ]; + $_stream->peer_hasclass->{$perlname} = [ $class, $smashkeys, $classid, $class ]; if( defined $classid ) { - $stream->message_state->{id2class}{$classid} = $perlname; + $_stream->message_state->{id2class}{$classid} = $perlname; } } -sub packmeta_struct +method packmeta_struct ( $struct ) { - my $self = shift; - my ( $struct ) = @_; - - my $stream = $self->{stream}; - $self->_pack_leader( DATA_META, DATAMETA_STRUCT ); my @fields = $struct->fields; - my $structid = ++$stream->message_state->{next_structid}; + my $structid = ++$_stream->message_state->{next_structid}; $self->pack_str( $struct->name ); $self->pack_int( $structid ); TYPE_LIST_STR->pack_value( $self, [ map { $_->name } @fields ] ); TYPE_LIST_STR->pack_value( $self, [ map { $_->type->sig } @fields ] ); - $stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ]; + $_stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ]; } -sub unpackmeta_struct +method unpackmeta_struct { - my $self = shift; - - my $stream = $self->{stream}; - my $name = $self->unpack_str(); my $structid = $self->unpack_int(); my $names = TYPE_LIST_STR->unpack_value( $self ); my $types = TYPE_LIST_STR->unpack_value( $self ); - my $struct = Tangence::Struct->new( name => $name ); + my $struct = Tangence::Struct->make( name => $name ); if( !$struct->defined ) { $struct->define( fields => [ @@ -511,26 +413,21 @@ sub unpackmeta_struct ); } - $stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ]; - $stream->message_state->{id2struct}{$structid} = $struct; + $_stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ]; + $_stream->message_state->{id2struct}{$structid} = $struct; } -sub pack_all_sametype +method pack_all_sametype ( $type, @d ) { - my $self = shift; - my $type = shift; - - $type->pack_value( $self, $_ ) for @_; + $type->pack_value( $self, $_ ) for @d; return $self; } -sub unpack_all_sametype +method unpack_all_sametype ( $type ) { - my $self = shift; - my ( $type ) = @_; my @data; - push @data, $type->unpack_value( $self ) while length $self->{record}; + push @data, $type->unpack_value( $self ) while length $_payload; return @data; } diff --git a/lib/Tangence/Meta/Argument.pm b/lib/Tangence/Meta/Argument.pm index 5c35dc8..b50e5f0 100644 --- a/lib/Tangence/Meta/Argument.pm +++ b/lib/Tangence/Meta/Argument.pm @@ -1,12 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2011-2012 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk -package Tangence::Meta::Argument 0.26; +use v5.26; +use Object::Pad 0.43; -use v5.14; -use warnings; +package Tangence::Meta::Argument 0.27; +class Tangence::Meta::Argument :strict(params); =head1 NAME @@ -45,12 +46,8 @@ Type of the arugment as a L<Tangence::Meta::Type> reference =cut -sub new -{ - my $class = shift; - my %args = @_; - bless \%args, $class; -} +has $name :reader :param = undef; +has $type :reader :param; =head1 ACCESSORS @@ -64,12 +61,6 @@ Returns the name of the class =cut -sub name -{ - my $self = shift; - return $self->{name}; -} - =head2 type $type = $argument->type @@ -78,12 +69,6 @@ Return the type as a L<Tangence::Meta::Type> reference. =cut -sub type -{ - my $self = shift; - return $self->{type}; -} - =head1 AUTHOR Paul Evans <leonerd@leonerd.org.uk> diff --git a/lib/Tangence/Meta/Class.pm b/lib/Tangence/Meta/Class.pm index 485e860..7a721f3 100644 --- a/lib/Tangence/Meta/Class.pm +++ b/lib/Tangence/Meta/Class.pm @@ -1,12 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2011-2017 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk -package Tangence::Meta::Class 0.26; +use v5.26; +use Object::Pad 0.43; -use v5.14; -use warnings; +package Tangence::Meta::Class 0.27; +class Tangence::Meta::Class :strict(params); use Carp; @@ -33,13 +34,13 @@ Returns a new instance representing the given name. =cut -sub new -{ - my $class = shift; - my %args = @_; - my $self = bless { name => delete $args{name} }, $class; - return $self; -} +has $name :param :reader; +has $defined :reader = 0; + +has @superclasses; +has %methods; +has %events; +has %properties; =head2 define @@ -68,18 +69,15 @@ C<Tangence::Meta::Class> references. =cut -sub define +method define ( %args ) { - my $self = shift; - my %args = @_; + $defined and croak "Cannot define $name twice"; - $self->defined and croak "Cannot define ".$self->name." twice"; - - $args{superclasses} ||= []; - $args{methods} ||= {}; - $args{events} ||= {}; - $args{properties} ||= {}; - $self->{$_} = $args{$_} for keys %args; + $defined++; + @superclasses = @{ delete $args{superclasses} // [] }; + %methods = %{ delete $args{methods} // {} }; + %events = %{ delete $args{events} // {} }; + %properties = %{ delete $args{properties} // {} }; } =head1 ACCESSORS @@ -94,12 +92,6 @@ Returns true if a definintion for the class has been provided using C<define>. =cut -sub defined -{ - my $self = shift; - return exists $self->{superclasses}; -} - =head2 name $name = $class->name @@ -108,12 +100,6 @@ Returns the name of the class =cut -sub name -{ - my $self = shift; - return $self->{name}; -} - =head2 perlname $perlname = $class->perlname @@ -123,9 +109,8 @@ replaced by double colons (C<::>). =cut -sub perlname +method perlname { - my $self = shift; ( my $perlname = $self->name ) =~ s{\.}{::}g; # s///rg in 5.14 return $perlname; } @@ -139,11 +124,10 @@ references. =cut -sub direct_superclasses +method direct_superclasses { - my $self = shift; - $self->defined or croak $self->name . " is not yet defined"; - return @{ $self->{superclasses} }; + $defined or croak "$name is not yet defined"; + return @superclasses; } =head2 direct_methods @@ -156,11 +140,10 @@ L<Tangence::Meta::Method> instances. =cut -sub direct_methods +method direct_methods { - my $self = shift; - $self->defined or croak $self->name . " is not yet defined"; - return $self->{methods}; + $defined or croak "$name is not yet defined"; + return { %methods }; } =head2 direct_events @@ -173,11 +156,10 @@ L<Tangence::Meta::Event> instances. =cut -sub direct_events +method direct_events { - my $self = shift; - $self->defined or croak $self->name . " is not yet defined"; - return $self->{events}; + $defined or croak "$name is not yet defined"; + return { %events }; } =head2 direct_properties @@ -190,11 +172,10 @@ L<Tangence::Meta::Property> instances. =cut -sub direct_properties +method direct_properties { - my $self = shift; - $self->defined or croak $self->name . " is not yet defined"; - return $self->{properties}; + $defined or croak "$name is not yet defined"; + return { %properties }; } =head1 AGGREGATE ACCESSORS @@ -213,13 +194,12 @@ references. =cut -sub superclasses +method superclasses { - my $self = shift; # This algorithm doesn't have to be particularly good, C3 or whatever. # We're not really forming a search order, mearly uniq'ifying my %seen; - return grep { !$seen{$_}++ } map { $_, $_->superclasses } $self->direct_superclasses; + return grep { !$seen{$_}++ } map { $_, $_->superclasses } @superclasses; } =head2 methods @@ -231,9 +211,8 @@ names to L<Tangence::Meta::Method> instances. =cut -sub methods +method methods { - my $self = shift; my %methods; foreach ( $self, $self->superclasses ) { my $m = $_->direct_methods; @@ -251,10 +230,8 @@ if no such method exists. =cut -sub method +method method ( $name ) { - my $self = shift; - my ( $name ) = @_; return $self->methods->{$name}; } @@ -267,9 +244,8 @@ names to L<Tangence::Meta::Event> instances. =cut -sub events +method events { - my $self = shift; my %events; foreach ( $self, $self->superclasses ) { my $e = $_->direct_events; @@ -287,10 +263,8 @@ no such event exists. =cut -sub event +method event ( $name ) { - my $self = shift; - my ( $name ) = @_; return $self->events->{$name}; } @@ -303,9 +277,8 @@ names to L<Tangence::Meta::Property> instances. =cut -sub properties +method properties { - my $self = shift; my %properties; foreach ( $self, $self->superclasses ) { my $p = $_->direct_properties; @@ -323,10 +296,8 @@ C<undef> if no such property exists. =cut -sub property +method property ( $name ) { - my $self = shift; - my ( $name ) = @_; return $self->properties->{$name}; } diff --git a/lib/Tangence/Meta/Event.pm b/lib/Tangence/Meta/Event.pm index 8f24782..25cf2e0 100644 --- a/lib/Tangence/Meta/Event.pm +++ b/lib/Tangence/Meta/Event.pm @@ -1,14 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2011-2017 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk -package Tangence::Meta::Event 0.26; +use v5.26; +use Object::Pad 0.51; -use v5.14; -use warnings; - -use Scalar::Util qw( weaken ); +package Tangence::Meta::Event 0.27; +class Tangence::Meta::Event :strict(params); =head1 NAME @@ -50,14 +49,14 @@ L<Tangence::Meta::Argument> references. =cut -sub new +has $class :param :weak :reader; +has $name :param :reader; +has @arguments; + +ADJUSTPARAMS ( $params ) { - my $class = shift; - my %args = @_; - $args{arguments} ||= []; - my $self = bless \%args, $class; - weaken $self->{class}; - return $self; + exists $params->{arguments} and + @arguments = @{ delete $params->{arguments} }; } =head1 ACCESSORS @@ -72,12 +71,6 @@ Returns the class the event is a member of =cut -sub class -{ - my $self = shift; - return $self->{class}; -} - =head2 name $name = $event->name @@ -86,12 +79,6 @@ Returns the name of the class =cut -sub name -{ - my $self = shift; - return $self->{name}; -} - =head2 arguments @arguments = $event->arguments @@ -100,11 +87,7 @@ Return the arguments in a list of L<Tangence::Meta::Argument> references. =cut -sub arguments -{ - my $self = shift; - return @{ $self->{arguments} }; -} +method arguments { @arguments } =head2 argtypes @@ -114,10 +97,9 @@ Return the argument types in a list of strings. =cut -sub argtypes +method argtypes { - my $self = shift; - return map { $_->type } $self->arguments; + return map { $_->type } @arguments; } =head1 AUTHOR diff --git a/lib/Tangence/Meta/Field.pm b/lib/Tangence/Meta/Field.pm index 1e00b1c..7e0c1d9 100644 --- a/lib/Tangence/Meta/Field.pm +++ b/lib/Tangence/Meta/Field.pm @@ -1,12 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2012-2017 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2012-2021 -- leonerd@leonerd.org.uk -package Tangence::Meta::Field 0.26; +use v5.26; +use Object::Pad 0.41; -use v5.14; -use warnings; +package Tangence::Meta::Field 0.27; +class Tangence::Meta::Field :strict(params); =head1 NAME @@ -44,12 +45,8 @@ Type of the field as a L<Tangence::Meta::Type> reference =cut -sub new -{ - my $class = shift; - my %args = @_; - bless \%args, $class; -} +has $name :param :reader; +has $type :param :reader; =head1 ACCESSORS @@ -63,12 +60,6 @@ Returns the name of the field =cut -sub name -{ - my $self = shift; - return $self->{name}; -} - =head2 type $type = $field->type @@ -77,12 +68,6 @@ Return the type as a L<Tangence::Meta::Type> reference. =cut -sub type -{ - my $self = shift; - return $self->{type}; -} - =head1 AUTHOR Paul Evans <leonerd@leonerd.org.uk> diff --git a/lib/Tangence/Meta/Method.pm b/lib/Tangence/Meta/Method.pm index a7c01da..43e1571 100644 --- a/lib/Tangence/Meta/Method.pm +++ b/lib/Tangence/Meta/Method.pm @@ -1,14 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2011-2017 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk -package Tangence::Meta::Method 0.26; +use v5.26; +use Object::Pad 0.51; -use v5.14; -use warnings; - -use Scalar::Util qw( weaken ); +package Tangence::Meta::Method 0.27; +class Tangence::Meta::Method :strict(params); =head1 NAME @@ -55,14 +54,15 @@ reference =cut -sub new +has $class :param :weak :reader; +has $name :param :reader; +has @arguments; +has $ret :param :reader; + +ADJUSTPARAMS ( $params ) { - my $class = shift; - my %args = @_; - $args{arguments} ||= []; - my $self = bless \%args, $class; - weaken $self->{class}; - return $self; + exists $params->{arguments} and + @arguments = @{ delete $params->{arguments} }; } =head1 ACCESSORS @@ -77,12 +77,6 @@ Returns the class the method is a member of =cut -sub class -{ - my $self = shift; - return $self->{class}; -} - =head2 name $name = $method->name @@ -91,12 +85,6 @@ Returns the name of the class =cut -sub name -{ - my $self = shift; - return $self->{name}; -} - =head2 arguments @arguments = $method->arguments @@ -105,11 +93,7 @@ Return the arguments in a list of L<Tangence::Meta::Argument> references. =cut -sub arguments -{ - my $self = shift; - return @{ $self->{arguments} }; -} +method arguments { @arguments } =head2 argtype @@ -119,10 +103,9 @@ Return the argument types in a list of L<Tangence::Meta::Type> references. =cut -sub argtypes +method argtypes { - my $self = shift; - return map { $_->type } $self->arguments; + return map { $_->type } @arguments; } =head2 ret @@ -134,12 +117,6 @@ the method does not return a value. =cut -sub ret -{ - my $self = shift; - return $self->{ret}; -} - =head1 AUTHOR Paul Evans <leonerd@leonerd.org.uk> diff --git a/lib/Tangence/Meta/Property.pm b/lib/Tangence/Meta/Property.pm index 5ed1ddc..3d13455 100644 --- a/lib/Tangence/Meta/Property.pm +++ b/lib/Tangence/Meta/Property.pm @@ -1,16 +1,17 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2011-2017 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk -package Tangence::Meta::Property 0.26; +use v5.26; +use Object::Pad 0.44; -use v5.14; -use warnings; +package Tangence::Meta::Property 0.27; +class Tangence::Meta::Property :strict(params); -use Tangence::Constants; +use Syntax::Keyword::Match; -use Scalar::Util qw( weaken ); +use Tangence::Constants; =head1 NAME @@ -60,14 +61,11 @@ Optional. If true, marks that the property is smashed. =cut -sub new -{ - my $class = shift; - my %args = @_; - my $self = bless \%args, $class; - weaken $self->{class}; - return $self; -} +has $class :param :weak :reader; +has $name :param :reader; +has $dimension :param :reader; +has $type :param :reader; +has $smashed :param :reader = 0; =head1 ACCESSORS @@ -81,12 +79,6 @@ Returns the class the property is a member of =cut -sub class -{ - my $self = shift; - return $self->{class}; -} - =head2 name $name = $property->name @@ -95,12 +87,6 @@ Returns the name of the class =cut -sub name -{ - my $self = shift; - return $self->{name}; -} - =head2 dimension $dimension = $property->dimension @@ -109,12 +95,6 @@ Returns the dimension as one of the C<DIM_*> constants. =cut -sub dimension -{ - my $self = shift; - return $self->{dimension}; -} - =head2 type $type = $property->type @@ -123,12 +103,6 @@ Returns the element type as a L<Tangence::Meta::Type> reference. =cut -sub type -{ - my $self = shift; - return $self->{type}; -} - =head2 overall_type $type = $property->overall_type @@ -140,23 +114,26 @@ a list of the element type. =cut -sub overall_type +has $_overall_type; + +method overall_type { - my $self = shift; - return $self->{overall_type} ||= do { + return $_overall_type ||= do { my $type = $self->type; my $dim = $self->dimension; - if( $dim == DIM_SCALAR ) { - $type; - } - elsif( $dim == DIM_HASH ) { - $self->make_type( dict => $type ); - } - elsif( $dim == DIM_ARRAY or $dim == DIM_QUEUE or $dim == DIM_OBJSET ) { - $self->make_type( list => $type ); - } - else { - die "Unrecognised dimension $dim for ->overall_type"; + match( $dim : == ) { + case( DIM_SCALAR ) { + $type; + } + case( DIM_HASH ) { + $self->make_type( dict => $type ); + } + case( DIM_ARRAY ), case( DIM_QUEUE ), case( DIM_OBJSET ) { + $self->make_type( list => $type ); + } + default { + die "Unrecognised dimension $dim for ->overall_type"; + } } } } @@ -169,17 +146,10 @@ Returns true if the property is smashed. =cut -sub smashed -{ - my $self = shift; - return $self->{smashed}; -} - # For subclasses to override if required -sub make_type +method make_type { - shift; - return Tangence::Meta::Type->new( @_ ); + return Tangence::Meta::Type->make( @_ ); } =head1 AUTHOR diff --git a/lib/Tangence/Meta/Struct.pm b/lib/Tangence/Meta/Struct.pm index ab38c7b..8b160a6 100644 --- a/lib/Tangence/Meta/Struct.pm +++ b/lib/Tangence/Meta/Struct.pm @@ -1,12 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2012-2017 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2012-2021 -- leonerd@leonerd.org.uk -package Tangence::Meta::Struct 0.26; +use v5.26; +use Object::Pad 0.43; -use v5.14; -use warnings; +package Tangence::Meta::Struct 0.27; +class Tangence::Meta::Struct :strict(params); use Carp; @@ -34,13 +35,10 @@ Returns a new instance representing the given name. =cut -sub new -{ - my $class = shift; - my %args = @_; - my $self = bless { name => delete $args{name} }, $class; - return $self; -} +has $name :param :reader; +has $defined :reader = 0; + +has @fields; =head2 define @@ -59,14 +57,12 @@ of L<Tangence::Meta::Field>. =cut -sub define +method define ( %args ) { - my $self = shift; - my %args = @_; + $defined and croak "Cannot define $name twice"; - $self->defined and croak "Cannot define ".$self->name." twice"; - - $self->{fields} = $args{fields}; + $defined++; + @fields = @{ $args{fields} }; } =head1 ACCESSORS @@ -82,12 +78,6 @@ C<define>. =cut -sub defined -{ - my $self = shift; - return exists $self->{fields}; -} - =head2 name $name = $struct->name @@ -96,12 +86,6 @@ Returns the name of the structure =cut -sub name -{ - my $self = shift; - return $self->{name}; -} - =head2 fields @fields = $struct->fields @@ -111,11 +95,10 @@ definition. =cut -sub fields +method fields { - my $self = shift; $self->defined or croak $self->name . " is not yet defined"; - return @{ $self->{fields} }; + return @fields; } =head1 AUTHOR diff --git a/lib/Tangence/Meta/Type.pm b/lib/Tangence/Meta/Type.pm index ffb0a11..7a13960 100644 --- a/lib/Tangence/Meta/Type.pm +++ b/lib/Tangence/Meta/Type.pm @@ -1,12 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2012-2017 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2012-2021 -- leonerd@leonerd.org.uk -package Tangence::Meta::Type 0.26; +use v5.26; +use Object::Pad 0.41; -use v5.14; -use warnings; +package Tangence::Meta::Type 0.27; +class Tangence::Meta::Type :strict(params); use Carp; @@ -20,7 +21,8 @@ This data structure object represents information about a type, such as a method or event argument, a method return value, or a property element type. Due to their simple contents and immutable nature, these objects may be -implemented as singletons. +implemented as singletons. Repeated calls to the constructor method for the +same type name will yield the same instance. =cut @@ -28,13 +30,13 @@ implemented as singletons. =cut -=head2 new +=head2 make - $type = Tangence::Meta::Type->new( $primitive ) + $type = Tangence::Meta::Type->make( $primitive ) Returns an instance to represent the given primitive type signature. - $type = Tangence::Meta::Type->new( $aggregate => $member_type ) + $type = Tangence::Meta::Type->make( $aggregate => $member_type ) Returns an instance to represent the given aggregation of the given type instance. @@ -45,49 +47,52 @@ our %PRIMITIVES; our %LISTS; our %DICTS; -sub new +sub make { my $class = shift; if( @_ == 1 ) { my ( $sig ) = @_; - return $PRIMITIVES{$sig} ||= bless [ prim => $sig ], $class; + return $PRIMITIVES{$sig} //= + $class->new( member_type => $sig ); } elsif( @_ == 2 and $_[0] eq "list" ) { my ( undef, $membertype ) = @_; - return $LISTS{$membertype->sig} ||= bless [ list => $membertype ], $class; + return $LISTS{$membertype->sig} //= + $class->new( aggregate => "list", member_type => $membertype ); } elsif( @_ == 2 and $_[0] eq "dict" ) { my ( undef, $membertype ) = @_; - return $DICTS{$membertype->sig} ||= bless [ dict => $membertype ], $class; + return $DICTS{$membertype->sig} //= + $class->new( aggregate => "dict", member_type => $membertype ); } die "TODO: @_"; } -=head2 new_from_sig +=head2 make _from_sig - $type = Tangence::Meta::Type->new_from_sig( $sig ) + $type = Tangence::Meta::Type->make_from_sig( $sig ) Parses the given full Tangence type signature and returns an instance to represent it. =cut -sub new_from_sig +sub make_from_sig ( $class, $sig ) { - my $class = shift; - my ( $sig ) = @_; - $sig =~ m/^list\((.*)\)$/ and - return $class->new( list => $class->new_from_sig( $1 ) ); + return $class->make( list => $class->make_from_sig( $1 ) ); $sig =~ m/^dict\((.*)\)$/ and - return $class->new( dict => $class->new_from_sig( $1 ) ); + return $class->make( dict => $class->make_from_sig( $1 ) ); - return $class->new( $sig ); + return $class->make( $sig ); } +has $aggregate :param :reader = "prim"; +has $member_type :param; + =head1 ACCESSORS =cut @@ -101,12 +106,6 @@ dict aggregate types. =cut -sub aggregate -{ - my $self = shift; - return $self->[0]; -} - =head2 member_type $member_type = $type->member_type @@ -116,11 +115,10 @@ primitive types. =cut -sub member_type +method member_type { - my $self = shift; - die "Cannot return the member type for primitive types" if $self->[0] eq "prim"; - return $self->[1]; + die "Cannot return the member type for primitive types" if $aggregate eq "prim"; + return $member_type; } =head2 sig @@ -131,28 +129,24 @@ Returns the Tangence type signature for the type. =cut -sub sig +method sig { - my $self = shift; - $self->${\"_sig_for_$self->[0]"}(); + return $self->${\"_sig_for_$aggregate"}(); } -sub _sig_for_prim +method _sig_for_prim { - my $self = shift; - return $self->[1]; + return $member_type; } -sub _sig_for_list +method _sig_for_list { - my $self = shift; - return "list(" . $self->[1]->sig . ")"; + return "list(" . $member_type->sig . ")"; } -sub _sig_for_dict +method _sig_for_dict { - my $self = shift; - return "dict(" . $self->[1]->sig . ")"; + return "dict(" . $member_type->sig . ")"; } =head1 AUTHOR diff --git a/lib/Tangence/Object.pm b/lib/Tangence/Object.pm index fcd8072..03d4bcf 100644 --- a/lib/Tangence/Object.pm +++ b/lib/Tangence/Object.pm @@ -1,15 +1,18 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2010-2017 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk -package Tangence::Object 0.26; +package Tangence::Object 0.27; -use v5.14; +use v5.26; use warnings; +use experimental 'signatures'; use Carp; +use Syntax::Keyword::Match; + use Tangence::Constants; use Tangence::Types; @@ -42,11 +45,8 @@ instead the C<Tangence::Registry> should be used to construct one. =cut -sub new +sub new ( $class, %args ) { - my $class = shift; - my %args = @_; - defined( my $id = delete $args{id} ) or croak "Need a id"; my $registry = delete $args{registry} or croak "Need a registry"; @@ -85,11 +85,8 @@ Not to be confused with Perl's own C<DESTROY> method. =cut -sub destroy +sub destroy ( $self, %args ) { - my $self = shift; - my %args = @_; - $self->{destroying} = 1; my $outstanding = 1; @@ -167,11 +164,8 @@ sub registry return $self->{registry}; } -sub smash +sub smash ( $self, $smashkeys ) { - my $self = shift; - my ( $smashkeys ) = @_; - return undef unless $smashkeys and @$smashkeys; my @keys; @@ -263,11 +257,8 @@ invoked with the given arguments. =cut -sub fire_event +sub fire_event ( $self, $event, @args ) { - my $self = shift; - my ( $event, @args ) = @_; - $event eq "destroy" and croak "$self cannot fire destroy event directly"; $self->can_event( $event ) or croak "$self has no event $event"; @@ -294,11 +285,8 @@ calling C<unsubscribe_event>. =cut -sub subscribe_event +sub subscribe_event ( $self, $event, $callback ) { - my $self = shift; - my ( $event, $callback ) = @_; - $self->can_event( $event ) or croak "$self has no event $event"; my $sublist = ( $self->{event_subs}->{$event} ||= [] ); @@ -318,11 +306,8 @@ C<subscribe_event>. =cut -sub unsubscribe_event +sub unsubscribe_event ( $self, $event, $id ) { - my $self = shift; - my ( $event, $id ) = @_; - my $sublist = $self->{event_subs}->{$event} or return; my $index; @@ -377,11 +362,8 @@ C<unwatch_property>. =cut -sub watch_property +sub watch_property ( $self, $prop, %callbacks ) { - my $self = shift; - my ( $prop, %callbacks ) = @_; - my $pdef = $self->can_property( $prop ) or croak "$self has no property $prop"; my $callbacks = {}; @@ -419,11 +401,8 @@ C<watch_property>. =cut -sub unwatch_property +sub unwatch_property ( $self, $prop, $id ) { - my $self = shift; - my ( $prop, $id ) = @_; - my $watchlist = $self->{properties}->{$prop}->callbacks or return; my $index; @@ -436,11 +415,8 @@ sub unwatch_property ### Message handling -sub handle_request_CALL +sub handle_request_CALL ( $self, $ctx, $message ) { - my $self = shift; - my ( $ctx, $message ) = @_; - my $method = $message->unpack_str(); my $mdef = $self->can_method( $method ) or die "Object cannot respond to method $method\n"; @@ -458,11 +434,8 @@ sub handle_request_CALL return $response; } -sub generate_message_EVENT +sub generate_message_EVENT ( $self, $conn, $event, @args ) { - my $self = shift; - my ( $conn, $event, @args ) = @_; - my $edef = $self->can_event( $event ) or die "Object cannot respond to event $event"; my $response = Tangence::Message->new( $conn, MSG_EVENT ) @@ -475,11 +448,8 @@ sub generate_message_EVENT return $response; } -sub handle_request_GETPROP +sub handle_request_GETPROP ( $self, $ctx, $message ) { - my $self = shift; - my ( $ctx, $message ) = @_; - my $prop = $message->unpack_str(); my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop"; @@ -495,11 +465,8 @@ sub handle_request_GETPROP return $response; } -sub handle_request_GETPROPELEM +sub handle_request_GETPROPELEM ( $self, $ctx, $message ) { - my $self = shift; - my ( $ctx, $message ) = @_; - my $prop = $message->unpack_str(); my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop"; @@ -509,16 +476,18 @@ sub handle_request_GETPROPELEM $self->can( $m ) or die "Object cannot get property $prop\n"; my $result; - if( $dim == DIM_QUEUE or $dim == DIM_ARRAY ) { - my $idx = $message->unpack_int(); - $result = $self->$m()->[$idx]; - } - elsif( $dim == DIM_HASH ) { - my $key = $message->unpack_str(); - $result = $self->$m()->{$key}; - } - else { - die "Property $prop cannot fetch elements"; + match( $dim : == ) { + case( DIM_QUEUE ), case( DIM_ARRAY ) { + my $idx = $message->unpack_int(); + $result = $self->$m()->[$idx]; + } + case( DIM_HASH ) { + my $key = $message->unpack_str(); + $result = $self->$m()->{$key}; + } + default { + die "Property $prop cannot fetch elements"; + } } my $response = Tangence::Message->new( $ctx->stream, MSG_RESULT ); @@ -527,11 +496,8 @@ sub handle_request_GETPROPELEM return $response; } -sub handle_request_SETPROP +sub handle_request_SETPROP ( $self, $ctx, $message ) { - my $self = shift; - my ( $ctx, $message ) = @_; - my $prop = $message->unpack_str(); my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop\n"; @@ -546,11 +512,8 @@ sub handle_request_SETPROP return Tangence::Message->new( $self, MSG_OK ); } -sub generate_message_UPDATE +sub generate_message_UPDATE ( $self, $conn, $prop, $how, @args ) { - my $self = shift; - my ( $conn, $prop, $how, @args ) = @_; - my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop\n"; my $dim = $pdef->dimension; @@ -574,93 +537,86 @@ sub generate_message_UPDATE return $message; } -sub _generate_message_UPDATE_scalar +sub _generate_message_UPDATE_scalar ( $self, $message, $how, $pdef, @args ) { - my $self = shift; - my ( $message, $how, $pdef, @args ) = @_; - croak "Change type $how is not valid for a scalar property"; } -sub _generate_message_UPDATE_hash +sub _generate_message_UPDATE_hash ( $self, $message, $how, $pdef, @args ) { - my $self = shift; - my ( $message, $how, $pdef, @args ) = @_; - - if( $how == CHANGE_ADD ) { - my ( $key, $value ) = @args; - $message->pack_str( $key ); - $pdef->type->pack_value( $message, $value ); - } - elsif( $how == CHANGE_DEL ) { - my ( $key ) = @args; - $message->pack_str( $key ); - } - else { - croak "Change type $how is not valid for a hash property"; + match( $how : == ) { + case( CHANGE_ADD ) { + my ( $key, $value ) = @args; + $message->pack_str( $key ); + $pdef->type->pack_value( $message, $value ); + } + case( CHANGE_DEL ) { + my ( $key ) = @args; + $message->pack_str( $key ); + } + default { + croak "Change type $how is not valid for a hash property"; + } } } -sub _generate_message_UPDATE_queue +sub _generate_message_UPDATE_queue ( $self, $message, $how, $pdef, @args ) { - my $self = shift; - my ( $message, $how, $pdef, @args ) = @_; - - if( $how == CHANGE_PUSH ) { - $message->pack_all_sametype( $pdef->type, @args ); - } - elsif( $how == CHANGE_SHIFT ) { - my ( $count ) = @args; - $message->pack_int( $count ); - } - else { - croak "Change type $how is not valid for a queue property"; + match( $how : == ) { + case( CHANGE_PUSH ) { + $message->pack_all_sametype( $pdef->type, @args ); + } + case( CHANGE_SHIFT ) { + my ( $count ) = @args; + $message->pack_int( $count ); + } + default { + croak "Change type $how is not valid for a queue property"; + } } } -sub _generate_message_UPDATE_array +sub _generate_message_UPDATE_array ( $self, $message, $how, $pdef, @args ) { - my $self = shift; - my ( $message, $how, $pdef, @args ) = @_; - - if( $how == CHANGE_PUSH ) { - $message->pack_all_sametype( $pdef->type, @args ); - } - elsif( $how == CHANGE_SHIFT ) { - my ( $count ) = @args; - $message->pack_int( $count ); - } - elsif( $how == CHANGE_SPLICE ) { - my ( $start, $count, @values ) = @args; - $message->pack_int( $start ); - $message->pack_int( $count ); - $message->pack_all_sametype( $pdef->type, @values ); - } - elsif( $how == CHANGE_MOVE ) { - my ( $index, $delta ) = @args; - $message->pack_int( $index ); - $message->pack_int( $delta ); - } - else { - croak "Change type $how is not valid for an array property"; + match( $how : == ) { + case( CHANGE_PUSH ) { + $message->pack_all_sametype( $pdef->type, @args ); + } + case( CHANGE_SHIFT ) { + my ( $count ) = @args; + $message->pack_int( $count ); + } + case( CHANGE_SPLICE ) { + my ( $start, $count, @values ) = @args; + $message->pack_int( $start ); + $message->pack_int( $count ); + $message->pack_all_sametype( $pdef->type, @values ); + } + case( CHANGE_MOVE ) { + my ( $index, $delta ) = @args; + $message->pack_int( $index ); + $message->pack_int( $delta ); + } + default { + croak "Change type $how is not valid for an array property"; + } } } -sub _generate_message_UPDATE_objset +sub _generate_message_UPDATE_objset ( $self, $message, $how, $pdef, @args ) { - my $self = shift; - my ( $message, $how, $pdef, @args ) = @_; - - if( $how == CHANGE_ADD ) { - my ( $value ) = @args; - $pdef->type->pack_value( $message, $value ); - } - elsif( $how == CHANGE_DEL ) { - my ( $id ) = @args; - $message->pack_int( $id ); - } - else { - croak "Change type $how is not valid for an objset property"; + match( $how : == ) { + case( CHANGE_ADD ) { + my ( $value ) = @args; + $pdef->type->pack_value( $message, $value ); + } + case( CHANGE_DEL ) { + my ( $id ) = @args; + $message->pack_int( $id ); + } + default { + croak "Change type $how is not valid for an objset property"; + } } } diff --git a/lib/Tangence/ObjectProxy.pm b/lib/Tangence/ObjectProxy.pm index 33a91d5..cc78a7c 100644 --- a/lib/Tangence/ObjectProxy.pm +++ b/lib/Tangence/ObjectProxy.pm @@ -1,15 +1,21 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2010-2020 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk -package Tangence::ObjectProxy 0.26; +use v5.26; +use Object::Pad 0.41; -use v5.14; -use warnings; +package Tangence::ObjectProxy 0.27; +class Tangence::ObjectProxy; use Carp; +use Syntax::Keyword::Match 0.06; + +use Future::AsyncAwait; +use Future::Exception; + use Tangence::Constants; use Tangence::Types; @@ -35,53 +41,36 @@ object. =cut -sub new -{ - my $class = shift; - my %args = @_; - - my $self = bless { - client => $args{client}, - id => $args{id}, - - class => $args{class}, +has $_client :param :weak :reader; +has $_id :param :reader; +has $_class :param :reader; - on_error => $args{on_error}, - }, $class; +has $_destroyed; - # An ObjectProxy is useless after its connection disappears - weaken( $self->{client} ); +has %_subscriptions; +has %_props; - return $self; -} - -sub destroy +method destroy { - my $self = shift; - - $self->{destroyed} = 1; + $_destroyed = 1; - foreach my $cb ( @{ $self->{subscriptions}->{destroy} } ) { + foreach my $cb ( @{ $_subscriptions{destroy} } ) { $cb->(); } - - undef %$self; - $self->{destroyed} = 1; } =head1 METHODS -The following methods documented with a trailing call to C<< ->get >> return -L<Future> instances. +The following methods documented in an C<await> expression return L<Future> +instances. =cut use overload '""' => \&STRING; -sub STRING +method STRING { - my $self = shift; - return "Tangence::ObjectProxy[id=$self->{id}]"; + return "Tangence::ObjectProxy[id=$_id]"; } =head2 id @@ -92,11 +81,7 @@ Returns the object ID for the C<Tangence> object being proxied for. =cut -sub id -{ - my $self = shift; - return $self->{id}; -} +# generated accessor =head2 classname @@ -106,10 +91,9 @@ Returns the name of the class of the C<Tangence> object being proxied for. =cut -sub classname +method classname { - my $self = shift; - return $self->{class}->name; + return $_class->name; } =head2 class @@ -121,11 +105,7 @@ object. =cut -sub class -{ - my $self = shift; - return $self->{class}; -} +# generated accessor =head2 can_method @@ -136,10 +116,9 @@ C<undef> if no such method exists. =cut -sub can_method +method can_method { - my $self = shift; - return $self->class->method( @_ ); + return $_class->method( @_ ); } =head2 can_event @@ -151,10 +130,9 @@ C<undef> if no such event exists. =cut -sub can_event +method can_event { - my $self = shift; - return $self->class->event( @_ ); + return $_class->event( @_ ); } =head2 can_property @@ -166,30 +144,25 @@ property, or C<undef> if no such property exists. =cut -sub can_property +method can_property { - my $self = shift; - return $self->class->property( @_ ); + return $_class->property( @_ ); } # Don't want to call it "isa" -sub proxy_isa +method proxy_isa { - my $self = shift; if( @_ ) { my ( $class ) = @_; - return !! grep { $_->name eq $class } $self->{class}, $self->{class}->superclasses; + return !! grep { $_->name eq $class } $_class, $_class->superclasses; } else { - return $self->{class}, $self->{class}->superclasses + return $_class, $_class->superclasses } } -sub grab +method grab ( $smashdata ) { - my $self = shift; - my ( $smashdata ) = @_; - foreach my $property ( keys %{ $smashdata } ) { my $value = $smashdata->{$property}; my $dim = $self->can_property( $property )->dimension; @@ -199,25 +172,22 @@ sub grab $value = { map { $_->id => $_ } @$value }; } - my $prop = $self->{props}->{$property} ||= {}; + my $prop = $_props{$property} ||= {}; $prop->{cache} = $value; } } =head2 call_method - $result = $proxy->call_method( $mname, @args )->get + $result = await $proxy->call_method( $mname, @args ) Calls the given method on the server object, passing in the given arguments. Returns a L<Future> that will yield the method's result. =cut -sub call_method +async method call_method ( $method, @args ) { - my $self = shift; - my ( $method, @args ) = @_; - # Detect void-context legacy uses defined wantarray or croak "->call_method in void context no longer useful - it now returns a Future"; @@ -225,36 +195,30 @@ sub call_method my $mdef = $self->can_method( $method ) or croak "Class ".$self->classname." does not have a method $method"; - my $client = $self->{client}; - - my $request = Tangence::Message->new( $client, MSG_CALL ) + my $request = Tangence::Message->new( $_client, MSG_CALL ) ->pack_int( $self->id ) ->pack_str( $method ); my @argtypes = $mdef->argtypes; $argtypes[$_]->pack_value( $request, $args[$_] ) for 0..$#argtypes; - $client->request( - request => $request, - )->then( sub { - my ( $message ) = @_; + my $message = await $_client->request( request => $request ); - my $code = $message->code; + my $code = $message->code; - if( $code == MSG_RESULT ) { - my $result = $mdef->ret ? $mdef->ret->unpack_value( $message ) - : undef; - Future->done( $result ); - } - else { - Future->fail( "Unexpected response code $code", tangence => ); - } - }); + if( $code == MSG_RESULT ) { + my $result = $mdef->ret ? $mdef->ret->unpack_value( $message ) + : undef; + return $result; + } + else { + Future::Exception->throw( "Unexpected response code $code", tangence => ); + } } =head2 subscribe_event - $proxy->subscribe_event( $event, %callbacks )->get + await $proxy->subscribe_event( $event, %callbacks ) Subscribes to the given event on the server object, installing a callback function which will be invoked whenever the event is fired. @@ -276,11 +240,8 @@ of the C<on_fire> event handler. =cut -sub subscribe_event +async method subscribe_event ( $event, %args ) { - my $self = shift; - my ( $event, %args ) = @_; - # Detect void-context legacy uses defined wantarray or croak "->subscribe_event in void context no longer useful - it now returns a Future"; @@ -291,46 +252,40 @@ sub subscribe_event $self->can_event( $event ) or croak "Class ".$self->classname." does not have an event $event"; - if( my $cbs = $self->{subscriptions}->{$event} ) { + if( my $cbs = $_subscriptions{$event} ) { push @$cbs, $callback; - return Future->done; + return; } my @cbs = ( $callback ); - $self->{subscriptions}->{$event} = \@cbs; + $_subscriptions{$event} = \@cbs; - return Future->done if $event eq "destroy"; # This is automatically handled - - my $client = $self->{client}; + return if $event eq "destroy"; # This is automatically handled - $client->request( - request => Tangence::Message->new( $client, MSG_SUBSCRIBE ) + my $message = await $_client->request( + request => Tangence::Message->new( $_client, MSG_SUBSCRIBE ) ->pack_int( $self->id ) - ->pack_str( $event ), - )->then( sub { - my ( $message ) = @_; - my $code = $message->code; + ->pack_str( $event ) + ); - if( $code == MSG_SUBSCRIBED ) { - Future->done; - } - else { - Future->fail( "Unexpected response code $code", tangence => ); - } - }); + my $code = $message->code; + + if( $code == MSG_SUBSCRIBED ) { + return; + } + else { + Future::Exception->throw( "Unexpected response code $code", tangence => ); + } } -sub handle_request_EVENT +method handle_request_EVENT ( $message ) { - my $self = shift; - my ( $message ) = @_; - my $event = $message->unpack_str(); my $edef = $self->can_event( $event ) or return; my @args = map { $_->unpack_value( $message ) } $edef->argtypes; - if( my $cbs = $self->{subscriptions}->{$event} ) { + if( my $cbs = $_subscriptions{$event} ) { foreach my $cb ( @$cbs ) { $cb->( @args ) } } } @@ -344,19 +299,15 @@ previously installed using C<subscribe_event>. =cut -sub unsubscribe_event +method unsubscribe_event ( $event ) { - my $self = shift; - my ( $event ) = @_; - $self->can_event( $event ) or croak "Class ".$self->classname." does not have an event $event"; return if $event eq "destroy"; # This is automatically handled - my $client = $self->{client}; - $client->request( - request => Tangence::Message->new( $client, MSG_UNSUBSCRIBE ) + $_client->request( + request => Tangence::Message->new( $_client, MSG_UNSUBSCRIBE ) ->pack_int( $self->id ) ->pack_str( $event ), @@ -366,17 +317,14 @@ sub unsubscribe_event =head2 get_property - $value = $proxy->get_property( $prop )->get + await $value = $proxy->get_property( $prop ) Requests the current value of the property from the server object. =cut -sub get_property +async method get_property ( $property ) { - my $self = shift; - my ( $property ) = @_; - # Detect void-context legacy uses defined wantarray or croak "->get_property in void context no longer useful - it now returns a Future"; @@ -384,39 +332,33 @@ sub get_property my $pdef = $self->can_property( $property ) or croak "Class ".$self->classname." does not have a property $property"; - my $client = $self->{client}; - $client->request( - request => Tangence::Message->new( $client, MSG_GETPROP ) + my $message = await $_client->request( + request => Tangence::Message->new( $_client, MSG_GETPROP ) ->pack_int( $self->id ) ->pack_str( $property ), - )->then( sub { - my ( $message ) = @_; - my $code = $message->code; + ); - if( $code == MSG_RESULT ) { - my $value = $pdef->overall_type->unpack_value( $message ); - Future->done( $value ); - } - else { - Future->fail( "Unexpected response code $code", tangence => ); - } - }); + my $code = $message->code; + + if( $code == MSG_RESULT ) { + return $pdef->overall_type->unpack_value( $message ); + } + else { + Future::Exception->throw( "Unexpected response code $code", tangence => ); + } } =head2 get_property_element - $value = $proxy->get_property_element( $property, $index_or_key )->get + await $value = $proxy->get_property_element( $property, $index_or_key ) Requests the current value of an element of the property from the server object. =cut -sub get_property_element +async method get_property_element ( $property, $index_or_key ) { - my $self = shift; - my ( $property, $index_or_key ) = @_; - # Detect void-context legacy uses defined wantarray or croak "->get_property_element in void context no longer useful - it now returns a Future"; @@ -424,36 +366,34 @@ sub get_property_element my $pdef = $self->can_property( $property ) or croak "Class ".$self->classname." does not have a property $property"; - my $client = $self->{client}; - - my $request = Tangence::Message->new( $client, MSG_GETPROPELEM ) + my $request = Tangence::Message->new( $_client, MSG_GETPROPELEM ) ->pack_int( $self->id ) ->pack_str( $property ); - if( $pdef->dimension == DIM_HASH ) { - $request->pack_str( $index_or_key ); - } - elsif( $pdef->dimension == DIM_ARRAY or $pdef->dimension == DIM_QUEUE ) { - $request->pack_int( $index_or_key ); - } - else { - croak "Cannot get_property_element of a non hash, array or queue"; + match( $pdef->dimension : == ) { + case( DIM_HASH ) { + $request->pack_str( $index_or_key ); + } + case( DIM_ARRAY ), case( DIM_QUEUE ) { + $request->pack_int( $index_or_key ); + } + default { + croak "Cannot get_property_element of a non hash, array or queue"; + } } - $client->request( + my $message = await $_client->request( request => $request, - )->then( sub { - my ( $message ) = @_; - my $code = $message->code; + ); - if( $code == MSG_RESULT ) { - my $value = $pdef->type->unpack_value( $message ); - Future->done( $value ); - } - else { - Future->fail( "Unexpected response code $code", tangence => ); - } - }); + my $code = $message->code; + + if( $code == MSG_RESULT ) { + return $pdef->type->unpack_value( $message ); + } + else { + Future::Exception->throw( "Unexpected response code $code", tangence => ); + } } =head2 prop @@ -465,13 +405,10 @@ is not a smashed property, an exception is thrown. =cut -sub prop +method prop ( $property ) { - my $self = shift; - my ( $property ) = @_; - - if( exists $self->{props}->{$property}->{cache} ) { - return $self->{props}->{$property}->{cache}; + if( exists $_props{$property}->{cache} ) { + return $_props{$property}->{cache}; } croak "$self does not have a cached property '$property'"; @@ -479,17 +416,14 @@ sub prop =head2 set_property - $proxy->set_property( $prop, $value )->get + await $proxy->set_property( $prop, $value ) Sets the value of the property in the server object. =cut -sub set_property +async method set_property ( $property, $value ) { - my $self = shift; - my ( $property, $value ) = @_; - # Detect void-context legacy uses defined wantarray or croak "->set_property in void context no longer useful - it now returns a Future"; @@ -497,34 +431,32 @@ sub set_property my $pdef = $self->can_property( $property ) or croak "Class ".$self->classname." does not have a property $property"; - my $client = $self->{client}; - my $request = Tangence::Message->new( $client, MSG_SETPROP ) + my $request = Tangence::Message->new( $_client, MSG_SETPROP ) ->pack_int( $self->id ) ->pack_str( $property ); $pdef->overall_type->pack_value( $request, $value ); - $client->request( + my $message = await $_client->request( request => $request, - )->then( sub { - my ( $message ) = @_; - my $code = $message->code; + ); - if( $code == MSG_OK ) { - Future->done; - } - else { - Future->fail( "Unexpected response code $code", tangence => ); - } - }); + my $code = $message->code; + + if( $code == MSG_OK ) { + return; + } + else { + Future::Exception->throw( "Unexpected response code $code", tangence => ); + } } =head2 watch_property - $proxy->watch_property( $property, %callbacks )->get + await $proxy->watch_property( $property, %callbacks ) =head2 watch_property_with_initial - $proxy->watch_property_with_initial( $property, %callbacks )->get + await $proxy->watch_property_with_initial( $property, %callbacks ) Watches the given property on the server object, installing callback functions which will be invoked whenever the property value changes. The latter form @@ -553,10 +485,8 @@ L<Tangence::Object>. =cut -sub _watchcbs_from_args +sub _watchcbs_from_args ( $pdef, %args ) { - my ( $pdef, %args ) = @_; - my $callbacks = {}; my $on_updated = delete $args{on_updated}; if( $on_updated ) { @@ -575,14 +505,11 @@ sub _watchcbs_from_args return $callbacks; } -sub watch_property { shift->_watch_property( shift, 0, @_ ) } -sub watch_property_with_initial { shift->_watch_property( shift, 1, @_ ) } +method watch_property { $self->_watch_property( shift, 0, @_ ) } +method watch_property_with_initial { $self->_watch_property( shift, 1, @_ ) } -sub _watch_property +async method _watch_property ( $property, $want_initial, %args ) { - my $self = shift; - my ( $property, $want_initial, %args ) = @_; - # Detect void-context legacy uses defined wantarray or croak "->watch_property in void context no longer useful - it now returns a Future"; @@ -595,69 +522,63 @@ sub _watch_property # Smashed properties behave differently my $smash = $pdef->smashed; - if( my $cbs = $self->{props}->{$property}->{cbs} ) { + if( my $cbs = $_props{$property}->{cbs} ) { if( $want_initial and !$smash ) { - return $self->get_property( $property ) - ->then( sub { - $callbacks->{on_set} and $callbacks->{on_set}->( $_[0] ); - $callbacks->{on_updated} and $callbacks->{on_updated}->( $_[0] ); - push @$cbs, $callbacks; - Future->done; - }); + my $value = await $self->get_property( $property ); + + $callbacks->{on_set} and $callbacks->{on_set}->( $value ); + $callbacks->{on_updated} and $callbacks->{on_updated}->( $value ); + push @$cbs, $callbacks; + return; } elsif( $want_initial and $smash ) { - my $cache = $self->{props}->{$property}->{cache}; + my $cache = $_props{$property}->{cache}; $callbacks->{on_set} and $callbacks->{on_set}->( $cache ); $callbacks->{on_updated} and $callbacks->{on_updated}->( $cache ); push @$cbs, $callbacks; - return Future->done; + return; } else { push @$cbs, $callbacks; - return Future->done; + return; } die "UNREACHED"; } - $self->{props}->{$property}->{cbs} = [ $callbacks ]; + $_props{$property}->{cbs} = [ $callbacks ]; if( $smash ) { if( $want_initial ) { - my $cache = $self->{props}->{$property}->{cache}; + my $cache = $_props{$property}->{cache}; $callbacks->{on_set} and $callbacks->{on_set}->( $cache ); $callbacks->{on_updated} and $callbacks->{on_updated}->( $cache ); } - return Future->done; + return; } - my $client = $self->{client}; - - my $request = Tangence::Message->new( $client, MSG_WATCH ) + my $request = Tangence::Message->new( $_client, MSG_WATCH ) ->pack_int( $self->id ) ->pack_str( $property ) ->pack_bool( $want_initial ); - $client->request( - request => $request, - )->then( sub { - my ( $message ) = @_; - my $code = $message->code; + my $message = await $_client->request( request => $request ); - if( $code == MSG_WATCHING ) { - Future->done; - } - else { - Future->fail( "Unexpected response code $code", tangence => ); - } - }); + my $code = $message->code; + + if( $code == MSG_WATCHING ) { + return; + } + else { + Future::Exception->throw( "Unexpected response code $code", tangence => ); + } } =head2 watch_property_with_cursor ( $cursor, $first_idx, $last_idx ) = - $proxy->watch_property_with_cursor( $property, $from, %callbacks )->get + await $proxy->watch_property_with_cursor( $property, $from, %callbacks ) A variant of C<watch_property> that installs a watch on the given property of the server object, and additionally returns an cursor object that can be used @@ -670,10 +591,8 @@ watch. =cut -sub watch_property_with_iter +method watch_property_with_iter { - my $self = shift; - # Detect void-context legacy uses defined wantarray or croak "->watch_property_with_iter in void context no longer useful - it now returns a Future"; @@ -681,19 +600,12 @@ sub watch_property_with_iter return $self->watch_property_with_cursor( @_ ); } -sub watch_property_with_cursor +async method watch_property_with_cursor ( $property, $from, %args ) { - my $self = shift; - my ( $property, $from, %args ) = @_; - - if( $from eq "first" ) { - $from = CUSR_FIRST; - } - elsif( $from eq "last" ) { - $from = CUSR_LAST; - } - else { - croak "Unrecognised 'from' value $from"; + match( $from : eq ) { + case( "first" ) { $from = CUSR_FIRST } + case( "last" ) { $from = CUSR_LAST } + default { croak "Unrecognised 'from' value $from" } } my $pdef = $self->can_property( $property ) @@ -704,47 +616,42 @@ sub watch_property_with_cursor # Smashed properties behave differently my $smashed = $pdef->smashed; - if( my $cbs = $self->{props}->{$property}->{cbs} ) { + if( my $cbs = $_props{$property}->{cbs} ) { die "TODO: need to synthesize a second cursor for $self"; } - $self->{props}->{$property}->{cbs} = [ $callbacks ]; + $_props{$property}->{cbs} = [ $callbacks ]; if( $smashed ) { die "TODO: need to synthesize an cursor"; } - my $client = $self->{client}; $pdef->dimension == DIM_QUEUE or croak "Can only iterate on queue-dimension properties"; - $client->request( - request => Tangence::Message->new( $client, MSG_WATCH_CUSR ) + my $message = await $_client->request( + request => Tangence::Message->new( $_client, MSG_WATCH_CUSR ) ->pack_int( $self->id ) ->pack_str( $property ) ->pack_int( $from ), - )->then( sub { - my ( $message ) = @_; - my $code = $message->code; + ); - if( $code == MSG_WATCHING_CUSR ) { - my $cursor_id = $message->unpack_int(); - my $first_idx = $message->unpack_int(); - my $last_idx = $message->unpack_int(); + my $code = $message->code; - my $cursor = Tangence::ObjectProxy::_Cursor->new( $self, $cursor_id, $pdef->type ); - Future->done( $cursor, $first_idx, $last_idx ); - } - else { - Future->fail( "Unexpected response code $code", tangence => ); - } - }); + if( $code == MSG_WATCHING_CUSR ) { + my $cursor_id = $message->unpack_int(); + my $first_idx = $message->unpack_int(); + my $last_idx = $message->unpack_int(); + + my $cursor = Tangence::ObjectProxy::_Cursor->new( $self, $cursor_id, $pdef->type ); + return ( $cursor, $first_idx, $last_idx ); + } + else { + Future::Exception->throw( "Unexpected response code $code", tangence => ); + } } -sub handle_request_UPDATE +method handle_request_UPDATE ( $message ) { - my $self = shift; - my ( $message ) = @_; - my $prop = $message->unpack_str(); my $how = TYPE_U8->unpack_value( $message ); @@ -752,7 +659,7 @@ sub handle_request_UPDATE my $type = $pdef->type; my $dim = $pdef->dimension; - my $p = $self->{props}->{$prop} ||= {}; + my $p = $_props{$prop} ||= {}; my $dimname = DIMNAMES->[$dim]; if( my $code = $self->can( "_update_property_$dimname" ) ) { @@ -765,144 +672,139 @@ sub handle_request_UPDATE $_->{on_updated} and $_->{on_updated}->( $p->{cache} ) for @{ $p->{cbs} }; } -sub _update_property_scalar +method _update_property_scalar ( $p, $type, $how, $message ) { - my $self = shift; - my ( $p, $type, $how, $message ) = @_; - - if( $how == CHANGE_SET ) { - my $value = $type->unpack_value( $message ); - $p->{cache} = $value; - $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; - } - else { - croak "Change type $how is not valid for a scalar property"; + match( $how : == ) { + case( CHANGE_SET ) { + my $value = $type->unpack_value( $message ); + $p->{cache} = $value; + $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; + } + default { + croak "Change type $how is not valid for a scalar property"; + } } } -sub _update_property_hash +method _update_property_hash ( $p, $type, $how, $message ) { - my $self = shift; - my ( $p, $type, $how, $message ) = @_; - - if( $how == CHANGE_SET ) { - my $value = Tangence::Type->new( dict => $type )->unpack_value( $message ); - $p->{cache} = $value; - $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; - } - elsif( $how == CHANGE_ADD ) { - my $key = $message->unpack_str(); - my $value = $type->unpack_value( $message ); - $p->{cache}->{$key} = $value; - $_->{on_add} and $_->{on_add}->( $key, $value ) for @{ $p->{cbs} }; - } - elsif( $how == CHANGE_DEL ) { - my $key = $message->unpack_str(); - delete $p->{cache}->{$key}; - $_->{on_del} and $_->{on_del}->( $key ) for @{ $p->{cbs} }; - } - else { - croak "Change type $how is not valid for a hash property"; + match( $how : == ) { + case( CHANGE_SET ) { + my $value = Tangence::Type->make( dict => $type )->unpack_value( $message ); + $p->{cache} = $value; + $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; + } + case( CHANGE_ADD ) { + my $key = $message->unpack_str(); + my $value = $type->unpack_value( $message ); + $p->{cache}->{$key} = $value; + $_->{on_add} and $_->{on_add}->( $key, $value ) for @{ $p->{cbs} }; + } + case( CHANGE_DEL ) { + my $key = $message->unpack_str(); + delete $p->{cache}->{$key}; + $_->{on_del} and $_->{on_del}->( $key ) for @{ $p->{cbs} }; + } + default { + croak "Change type $how is not valid for a hash property"; + } } } -sub _update_property_queue +method _update_property_queue ( $p, $type, $how, $message ) { - my $self = shift; - my ( $p, $type, $how, $message ) = @_; - - if( $how == CHANGE_SET ) { - my $value = Tangence::Type->new( list => $type )->unpack_value( $message ); - $p->{cache} = $value; - $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; - } - elsif( $how == CHANGE_PUSH ) { - my @value = $message->unpack_all_sametype( $type ); - push @{ $p->{cache} }, @value; - $_->{on_push} and $_->{on_push}->( @value ) for @{ $p->{cbs} }; - } - elsif( $how == CHANGE_SHIFT ) { - my $count = $message->unpack_int(); - splice @{ $p->{cache} }, 0, $count, (); - $_->{on_shift} and $_->{on_shift}->( $count ) for @{ $p->{cbs} }; - } - else { - croak "Change type $how is not valid for a queue property"; + match( $how : == ) { + case( CHANGE_SET ) { + my $value = Tangence::Type->make( list => $type )->unpack_value( $message ); + $p->{cache} = $value; + $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; + } + case( CHANGE_PUSH ) { + my @value = $message->unpack_all_sametype( $type ); + push @{ $p->{cache} }, @value; + $_->{on_push} and $_->{on_push}->( @value ) for @{ $p->{cbs} }; + } + case( CHANGE_SHIFT ) { + my $count = $message->unpack_int(); + splice @{ $p->{cache} }, 0, $count, (); + $_->{on_shift} and $_->{on_shift}->( $count ) for @{ $p->{cbs} }; + } + default { + croak "Change type $how is not valid for a queue property"; + } } } -sub _update_property_array +method _update_property_array ( $p, $type, $how, $message ) { - my $self = shift; - my ( $p, $type, $how, $message ) = @_; - - if( $how == CHANGE_SET ) { - my $value = Tangence::Type->new( list => $type )->unpack_value( $message ); - $p->{cache} = $value; - $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; - } - elsif( $how == CHANGE_PUSH ) { - my @value = $message->unpack_all_sametype( $type ); - push @{ $p->{cache} }, @value; - $_->{on_push} and $_->{on_push}->( @value ) for @{ $p->{cbs} }; - } - elsif( $how == CHANGE_SHIFT ) { - my $count = $message->unpack_int(); - splice @{ $p->{cache} }, 0, $count, (); - $_->{on_shift} and $_->{on_shift}->( $count ) for @{ $p->{cbs} }; - } - elsif( $how == CHANGE_SPLICE ) { - my $start = $message->unpack_int(); - my $count = $message->unpack_int(); - my @value = $message->unpack_all_sametype( $type ); - splice @{ $p->{cache} }, $start, $count, @value; - $_->{on_splice} and $_->{on_splice}->( $start, $count, @value ) for @{ $p->{cbs} }; - } - elsif( $how == CHANGE_MOVE ) { - my $index = $message->unpack_int(); - my $delta = $message->unpack_int(); - # it turns out that exchanging neighbours is quicker by list assignment, - # but other times it's generally best to use splice() to extract then - # insert - if( abs($delta) == 1 ) { - @{$p->{cache}}[$index,$index+$delta] = @{$p->{cache}}[$index+$delta,$index]; + match( $how : == ) { + case( CHANGE_SET ) { + my $value = Tangence::Type->make( list => $type )->unpack_value( $message ); + $p->{cache} = $value; + $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; } - else { - my $elem = splice @{ $p->{cache} }, $index, 1, (); - splice @{ $p->{cache} }, $index + $delta, 0, ( $elem ); + case( CHANGE_PUSH ) { + my @value = $message->unpack_all_sametype( $type ); + push @{ $p->{cache} }, @value; + $_->{on_push} and $_->{on_push}->( @value ) for @{ $p->{cbs} }; + } + case( CHANGE_SHIFT ) { + my $count = $message->unpack_int(); + splice @{ $p->{cache} }, 0, $count, (); + $_->{on_shift} and $_->{on_shift}->( $count ) for @{ $p->{cbs} }; + } + case( CHANGE_SPLICE ) { + my $start = $message->unpack_int(); + my $count = $message->unpack_int(); + my @value = $message->unpack_all_sametype( $type ); + splice @{ $p->{cache} }, $start, $count, @value; + $_->{on_splice} and $_->{on_splice}->( $start, $count, @value ) for @{ $p->{cbs} }; + } + case( CHANGE_MOVE ) { + my $index = $message->unpack_int(); + my $delta = $message->unpack_int(); + # it turns out that exchanging neighbours is quicker by list assignment, + # but other times it's generally best to use splice() to extract then + # insert + if( abs($delta) == 1 ) { + @{$p->{cache}}[$index,$index+$delta] = @{$p->{cache}}[$index+$delta,$index]; + } + else { + my $elem = splice @{ $p->{cache} }, $index, 1, (); + splice @{ $p->{cache} }, $index + $delta, 0, ( $elem ); + } + $_->{on_move} and $_->{on_move}->( $index, $delta ) for @{ $p->{cbs} }; + } + default { + croak "Change type $how is not valid for an array property"; } - $_->{on_move} and $_->{on_move}->( $index, $delta ) for @{ $p->{cbs} }; - } - else { - croak "Change type $how is not valid for an array property"; } } -sub _update_property_objset +method _update_property_objset ( $p, $type, $how, $message ) { - my $self = shift; - my ( $p, $type, $how, $message ) = @_; - - if( $how == CHANGE_SET ) { - # Comes across in a LIST. We need to map id => obj - my $objects = Tangence::Type->new( list => $type )->unpack_value( $message ); - $p->{cache} = { map { $_->id => $_ } @$objects }; - $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; - } - elsif( $how == CHANGE_ADD ) { - # Comes as object only - my $obj = $type->unpack_value( $message ); - $p->{cache}->{$obj->id} = $obj; - $_->{on_add} and $_->{on_add}->( $obj ) for @{ $p->{cbs} }; - } - elsif( $how == CHANGE_DEL ) { - # Comes as ID number only - my $id = $message->unpack_int(); - delete $p->{cache}->{$id}; - $_->{on_del} and $_->{on_del}->( $id ) for @{ $p->{cbs} }; - } - else { - croak "Change type $how is not valid for an objset property"; + match( $how : == ) { + case( CHANGE_SET ) { + # Comes across in a LIST. We need to map id => obj + my $objects = Tangence::Type->make( list => $type )->unpack_value( $message ); + $p->{cache} = { map { $_->id => $_ } @$objects }; + $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} }; + } + case( CHANGE_ADD ) { + # Comes as object only + my $obj = $type->unpack_value( $message ); + $p->{cache}->{$obj->id} = $obj; + $_->{on_add} and $_->{on_add}->( $obj ) for @{ $p->{cbs} }; + } + case( CHANGE_DEL ) { + # Comes as ID number only + my $id = $message->unpack_int(); + delete $p->{cache}->{$id}; + $_->{on_del} and $_->{on_del}->( $id ) for @{ $p->{cbs} }; + } + default { + croak "Change type $how is not valid for an objset property"; + } } } @@ -915,20 +817,16 @@ previously installed using C<watch_property>. =cut -sub unwatch_property +method unwatch_property ( $property ) { - my $self = shift; - my ( $property ) = @_; - $self->can_property( $property ) or croak "Class ".$self->classname." does not have a property $property"; # TODO: mark cursors as destroyed and invalid - delete $self->{props}->{$property}; + delete $_props{$property}; - my $client = $self->{client}; - $client->request( - request => Tangence::Message->new( $client, MSG_UNWATCH ) + $_client->request( + request => Tangence::Message->new( $_client, MSG_UNWATCH ) ->pack_int( $self->id ) ->pack_str( $property ), @@ -936,10 +834,10 @@ sub unwatch_property ); } -package # hide from index - Tangence::ObjectProxy::_Cursor; -use Carp; -use Tangence::Constants; +class Tangence::ObjectProxy::_Cursor +{ + use Carp; + use Tangence::Constants; =head1 CURSOR METHODS @@ -948,37 +846,37 @@ by the C<watch_property_with_cursor> method. =cut -sub new -{ - my $class = shift; - return bless [ @_ ], $class; -} + has $obj :param :reader; + has $id :param :reader; + has $element_type :param; -sub obj { shift->[0] } -sub id { shift->[1] } -sub client { shift->obj->{client} } + sub BUILDARGS ( $class, $obj, $id, $element_type ) + { + return ( obj => $obj, id => $id, element_type => $element_type ); + } -sub DESTROY -{ - my $self = shift; + method client { $obj->client } - return unless $self->obj and my $id = $self->id and my $client = $self->client; + # TODO: Object::Pad probably should do this bit + method DESTROY + { + return unless $obj and my $client = $self->client; - $client->request( - request => Tangence::Message->new( $client, MSG_CUSR_DESTROY ) - ->pack_int( $id ), + $client->request( + request => Tangence::Message->new( $client, MSG_CUSR_DESTROY ) + ->pack_int( $id ), - on_response => sub {}, - ); -} + on_response => sub {}, + ); + } =head2 next_forward - ( $index, @more ) = $cursor->next_forward( $count )->get + ( $index, @more ) = await $cursor->next_forward( $count ) =head2 next_backward - ( $index, @more ) = $cursor->next_backward( $count )->get + ( $index, @more ) = await $cursor->next_backward( $count ) Requests the next items from the cursor. C<next_forward> moves forwards towards higher-numbered indices, and C<next_backward> moves backwards towards @@ -992,52 +890,43 @@ new elements if the cursor is already at the end. =cut -sub next_forward -{ - my $self = shift; - $self->_next( CUSR_FWD, @_ ); -} - -sub next_backward -{ - my $self = shift; - $self->_next( CUSR_BACK, @_ ); -} + method next_forward + { + $self->_next( CUSR_FWD, @_ ); + } -sub _next -{ - my $self = shift; - my ( $direction, $count ) = @_; + method next_backward + { + $self->_next( CUSR_BACK, @_ ); + } - # Detect void-context legacy uses - defined wantarray or - croak "->next_forward/backward in void context no longer useful - it now returns a Future"; + async method _next ( $direction, $count = 1 ) + { + # Detect void-context legacy uses + defined wantarray or + croak "->next_forward/backward in void context no longer useful - it now returns a Future"; - my $obj = $self->obj; - my $id = $self->id; - my $element_type = $self->[2]; + my $client = $self->client; - my $client = $self->client; + my $message = await $client->request( + request => Tangence::Message->new( $client, MSG_CUSR_NEXT ) + ->pack_int( $id ) + ->pack_int( $direction ) + ->pack_int( $count || 1 ), + ); - $client->request( - request => Tangence::Message->new( $client, MSG_CUSR_NEXT ) - ->pack_int( $id ) - ->pack_int( $direction ) - ->pack_int( $count || 1 ), - )->then( sub { - my ( $message ) = @_; my $code = $message->code; if( $code == MSG_CUSR_RESULT ) { - Future->done( + return ( $message->unpack_int(), $message->unpack_all_sametype( $element_type ), ); } else { - Future->fail( "Unexpected response code $code", tangence => ); + Future::Exception->throw( "Unexpected response code $code", tangence => ); } - }); + } } =head1 AUTHOR diff --git a/lib/Tangence/Property.pm b/lib/Tangence/Property.pm index 83021f4..cb70776 100644 --- a/lib/Tangence/Property.pm +++ b/lib/Tangence/Property.pm @@ -3,9 +3,11 @@ # # (C) Paul Evans, 2013-2016 -- leonerd@leonerd.org.uk -package Tangence::Property 0.26; +use v5.26; +use Object::Pad 0.41; + +package Tangence::Property 0.27; -use v5.14; use warnings; use base qw( Tangence::Meta::Property ); @@ -247,58 +249,55 @@ sub _accessor_for_objset sub make_type { shift; - return Tangence::Type->new( @_ ); + return Tangence::Type->make( @_ ); } -package # hide from CPAN - Tangence::Property::_Cursor; +class # hide from CPAN + Tangence::Property::_Cursor +{ + use Carp; -use Carp; + use Tangence::Constants; -use Tangence::Constants; + has $queue :param :reader; + has $prop :param :reader; + has $idx :param :mutator; -sub new -{ - my $class = shift; - return bless [ @_ ], $class; -} + sub BUILDARGS ( $class, $queue, $prop, $idx ) + { + return ( queue => $queue, prop => $prop, idx => $idx ); + } -sub queue { shift->[0] } -sub prop { shift->[1] } -sub idx :lvalue { shift->[2] } + method handle_request_CUSR_NEXT + { + my ( $ctx, $message ) = @_; -sub handle_request_CUSR_NEXT -{ - my $self = shift; - my ( $ctx, $message ) = @_; + my $direction = $message->unpack_int(); + my $count = $message->unpack_int(); - my $direction = $message->unpack_int(); - my $count = $message->unpack_int(); + my $start_idx = $idx; - my $queue = $self->queue; - my $idx = $self->idx; + if( $direction == CUSR_FWD ) { + $count = scalar @$queue - $idx if $count > scalar @$queue - $idx; - if( $direction == CUSR_FWD ) { - $count = scalar @$queue - $idx if $count > scalar @$queue - $idx; + $idx += $count; + } + elsif( $direction == CUSR_BACK ) { + $count = $idx if $count > $idx; + $idx -= $count; + $start_idx = $idx; + } + else { + return $ctx->responderr( "Unrecognised cursor direction $direction" ); + } - $self->idx += $count; - } - elsif( $direction == CUSR_BACK ) { - $count = $idx if $count > $idx; - $idx -= $count; + my @result = @{$queue}[$start_idx .. $start_idx + $count - 1]; - $self->idx -= $count; + $ctx->respond( Tangence::Message->new( $ctx->stream, MSG_CUSR_RESULT ) + ->pack_int( $start_idx ) + ->pack_all_sametype( $prop->type, @result ) + ); } - else { - return $ctx->responderr( "Unrecognised cursor direction $direction" ); - } - - my @result = @{$queue}[$idx .. $idx + $count - 1]; - - $ctx->respond( Tangence::Message->new( $ctx->stream, MSG_CUSR_RESULT ) - ->pack_int( $idx ) - ->pack_all_sametype( $self->prop->type, @result ) - ); } 0x55AA; diff --git a/lib/Tangence/Registry.pm b/lib/Tangence/Registry.pm index 613eeeb..049d30e 100644 --- a/lib/Tangence/Registry.pm +++ b/lib/Tangence/Registry.pm @@ -1,13 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2010-2017 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk -package Tangence::Registry 0.26; +use v5.26; +use Object::Pad 0.51; -use v5.14; -use warnings; -use base qw( Tangence::Object ); +package Tangence::Registry 0.27; +class Tangence::Registry isa Tangence::Object; use Carp; @@ -75,33 +75,33 @@ connections to that server. =cut -sub new +sub BUILDARGS ( $class, %args ) { - my $class = shift; - my %args = @_; - - my $tanfile = $args{tanfile}; - croak "Expected 'tanfile'" unless defined $tanfile; - - my $id = 0; - - my $self = $class->SUPER::new( - id => $id, + return ( + id => 0, registry => "BOOTSTRAP", meta => Tangence::Class->for_perlname( $class ), + %args, ); - weaken( $self->{registry} = $self ); +} - $self->{objects} = { $id => $self }; - weaken( $self->{objects}{$id} ); - $self->add_prop_objects( $id => $self->describe ); +has $_nextid = 1; +has @_freeids; +has %_objects; - $self->{nextid} = 1; - $self->{freeids} = []; # free'd ids we can reuse +ADJUST +{ + my $id = 0; + weaken( $self->{registry} = $self ); - $self->load_tanfile( $tanfile ); + %_objects = ( $id => $self ); + weaken( $_objects{$id} ); + $self->add_prop_objects( $id => $self->describe ); +} - return $self; +ADJUSTPARAMS ( $params ) +{ + $self->load_tanfile( delete $params->{tanfile} ); } =head1 METHODS @@ -118,18 +118,13 @@ This method is exposed to clients. =cut -sub get_by_id +method get_by_id ( $id ) { - my $self = shift; - my ( $id ) = @_; - - return $self->{objects}->{$id}; + return $_objects{$id}; } -sub method_get_by_id +method method_get_by_id ( $ctx, $id ) { - my $self = shift; - my ( $ctx, $id ) = @_; return $self->get_by_id( $id ); } @@ -142,12 +137,9 @@ additional arguments are passed to the object's constructor. =cut -sub construct +method construct ( $type, @args ) { - my $self = shift; - my ( $type, @args ) = @_; - - my $id = shift @{ $self->{freeids} } || ( $self->{nextid}++ ); + my $id = shift @_freeids // ( $_nextid++ ); Tangence::Class->for_perlname( $type ) or croak "Registry cannot construct a '$type' as no class definition exists"; @@ -163,26 +155,23 @@ sub construct $self->fire_event( "object_constructed", $id ); - weaken( $self->{objects}->{$id} = $obj ); + weaken( $_objects{$id} = $obj ); $self->add_prop_objects( $id => $obj->describe ); return $obj; } -sub destroy_object +method destroy_object ( $obj ) { - my $self = shift; - my ( $obj ) = @_; - my $id = $obj->id; - exists $self->{objects}->{$id} or croak "Cannot destroy ID $id - does not exist"; + exists $_objects{$id} or croak "Cannot destroy ID $id - does not exist"; $self->del_prop_objects( $id ); $self->fire_event( "object_destroyed", $id ); - push @{ $self->{freeids} }, $id; # Recycle the ID + push @_freeids, $id; # Recycle the ID } =head2 load_tanfile @@ -194,41 +183,33 @@ file. =cut -sub load_tanfile +method load_tanfile ( $tanfile ) { - my $self = shift; - my ( $tanfile ) = @_; - # Merely constructing this has the side-effect of declaring all the classes Tangence::Registry::Parser->new->from_file( $tanfile ); } -package # hide from CPAN - Tangence::Registry::Parser; -use base qw( Tangence::Compiler::Parser ); - -sub make_class -{ - my $self = shift; - return Tangence::Class->new( @_ ); -} - -sub make_struct -{ - my $self = shift; - return Tangence::Struct->new( @_ ); -} - -sub make_property -{ - my $self = shift; - return Tangence::Property->new( @_ ); -} - -sub make_type +class Tangence::Registry::Parser isa Tangence::Compiler::Parser { - my $self = shift; - return Tangence::Type->new( @_ ); + method make_class + { + return Tangence::Class->make( @_ ); + } + + method make_struct + { + return Tangence::Struct->make( @_ ); + } + + method make_property + { + return Tangence::Property->new( @_ ); + } + + method make_type + { + return Tangence::Type->make( @_ ); + } } =head1 AUTHOR diff --git a/lib/Tangence/Server.pm b/lib/Tangence/Server.pm index 19e763a..bc3eb38 100644 --- a/lib/Tangence/Server.pm +++ b/lib/Tangence/Server.pm @@ -1,12 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2011-2020 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk -package Tangence::Server 0.26; +package Tangence::Server 0.27; -use v5.14; +use v5.26; use warnings; +use experimental 'signatures'; use base qw( Tangence::Stream ); @@ -137,11 +138,8 @@ sub tangence_closed } } -sub get_by_id +sub get_by_id ( $self, $id ) { - my $self = shift; - my ( $id ) = @_; - # Only permit the client to interact with objects they've already been # sent, so they cannot gain access by inventing object IDs $self->peer_hasobj->{$id} or @@ -153,11 +151,8 @@ sub get_by_id return $obj; } -sub handle_request_CALL +sub handle_request_CALL ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; @@ -175,11 +170,8 @@ sub handle_request_CALL $ctx->respond( $response ); } -sub handle_request_SUBSCRIBE +sub handle_request_SUBSCRIBE ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; @@ -215,11 +207,8 @@ sub handle_request_SUBSCRIBE $ctx->respond( $response ); } -sub handle_request_UNSUBSCRIBE +sub handle_request_UNSUBSCRIBE ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; @@ -250,11 +239,8 @@ sub handle_request_UNSUBSCRIBE $ctx->respond( $response ); } -sub handle_request_GETPROP +sub handle_request_GETPROP ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; @@ -272,11 +258,8 @@ sub handle_request_GETPROP $ctx->respond( $response ); } -sub handle_request_GETPROPELEM +sub handle_request_GETPROPELEM ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; @@ -294,11 +277,8 @@ sub handle_request_GETPROPELEM $ctx->respond( $response ); } -sub handle_request_SETPROP +sub handle_request_SETPROP ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; @@ -318,11 +298,8 @@ sub handle_request_SETPROP *handle_request_WATCH = \&_handle_request_WATCHany; *handle_request_WATCH_CUSR = \&_handle_request_WATCHany; -sub _handle_request_WATCHany +sub _handle_request_WATCHany ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $ctx = Tangence::Server::Context->new( $self, $token ); my ( $want_initial, $object, $prop ); @@ -367,11 +344,8 @@ sub _handle_request_WATCHany $self->_send_initial( $object, $prop ) if $want_initial; } -sub _send_initial +sub _send_initial ( $self, $object, $prop ) { - my $self = shift; - my ( $object, $prop ) = @_; - my $m = "get_prop_$prop"; return unless( $object->can( $m ) ); @@ -388,11 +362,8 @@ sub _send_initial } } -sub handle_request_UNWATCH +sub handle_request_UNWATCH ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $ctx = Tangence::Server::Context->new( $self, $token ); my $response; @@ -423,11 +394,8 @@ sub handle_request_UNWATCH $ctx->respond( $response ); } -sub handle_request_CUSR_NEXT +sub handle_request_CUSR_NEXT ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $cursor_id = $message->unpack_int(); my $ctx = Tangence::Server::Context->new( $self, $token ); @@ -438,11 +406,8 @@ sub handle_request_CUSR_NEXT $cursorobj->cursor->handle_request_CUSR_NEXT( $ctx, $message ); } -sub handle_request_CUSR_DESTROY +sub handle_request_CUSR_DESTROY ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $cursor_id = $message->unpack_int(); my $ctx = Tangence::Server::Context->new( $self, $token ); @@ -453,20 +418,14 @@ sub handle_request_CUSR_DESTROY $ctx->respond( Tangence::Message->new( $self, MSG_OK ) ); } -sub drop_cursorobj +sub drop_cursorobj ( $self, $cursorobj ) { - my $self = shift; - my ( $cursorobj ) = @_; - my $m = "uncursor_prop_" . $cursorobj->cursor->prop->name; $cursorobj->obj->$m( $cursorobj->cursor ); } -sub handle_request_INIT +sub handle_request_INIT ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $major = $message->unpack_int(); my $minor_max = $message->unpack_int(); my $minor_min = $message->unpack_int(); @@ -497,11 +456,8 @@ sub handle_request_INIT $ctx->respond( $response ); } -sub handle_request_GETROOT +sub handle_request_GETROOT ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - my $identity = TYPE_ANY->unpack_value( $message ); my $ctx = Tangence::Server::Context->new( $self, $token ); @@ -516,11 +472,8 @@ sub handle_request_GETROOT $ctx->respond( $response ); } -sub handle_request_GETREGISTRY +sub handle_request_GETREGISTRY ( $self, $token, $message ) { - my $self = shift; - my ( $token ) = @_; - my $ctx = Tangence::Server::Context->new( $self, $token ); $self->permit_registry or @@ -542,11 +495,8 @@ my %change_values = ( on_move => CHANGE_MOVE, ); -sub _install_watch +sub _install_watch ( $self, $object, $prop ) { - my $self = shift; - my ( $object, $prop ) = @_; - my $pdef = $object->can_property( $prop ); my $dim = $pdef->dimension; @@ -572,11 +522,8 @@ sub _install_watch push @{ $self->watches }, [ $object, $prop, $id ]; } -sub object_destroyed +sub object_destroyed ( $self, $obj, @rest ) { - my $self = shift; - my ( $obj ) = @_; - if( my $subs = $self->subscriptions ) { my $i = 0; while( $i < @$subs ) { @@ -607,7 +554,7 @@ sub object_destroyed } } - $self->SUPER::object_destroyed( @_ ); + $self->SUPER::object_destroyed( $obj, @rest ); } =head1 OVERRIDEABLE METHODS diff --git a/lib/Tangence/Server/Context.pm b/lib/Tangence/Server/Context.pm index b3e674d..6d7fc93 100644 --- a/lib/Tangence/Server/Context.pm +++ b/lib/Tangence/Server/Context.pm @@ -1,62 +1,50 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2010-2011 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk -package Tangence::Server::Context 0.26; +use v5.26; +use Object::Pad 0.41; -use v5.14; -use warnings; +package Tangence::Server::Context 0.27; +class Tangence::Server::Context; use Carp; use Tangence::Constants; -sub new -{ - my $class = shift; - my ( $stream, $token ) = @_; - - return bless { - stream => $stream, - token => $token, - }, $class; -} +has $stream :param :reader; +has $token :param; -sub DESTROY +sub BUILDARGS ( $class, $stream, $token ) { - my $self = shift; - $self->{responded} or croak "$self never responded"; + return ( stream => $stream, token => $token ); } -sub stream +has $responded; + +# TODO: Object::Pad probably should do this bit +method DESTROY { - my $self = shift; - return $self->{stream}; + $responded or croak "$self never responded"; } -sub respond +method respond ( $message ) { - my $self = shift; - my ( $message ) = @_; - - $self->{responded} and croak "$self has responded once already"; + $responded and croak "$self has responded once already"; - $self->stream->respond( $self->{token}, $message ); + $stream->respond( $token, $message ); - $self->{responded} = 1; + $responded = 1; return; } -sub responderr +method responderr ( $msg ) { - my $self = shift; - my ( $msg ) = @_; - chomp $msg; # In case of simple ->responderr( $@ ); - $self->respond( Tangence::Message->new( $self->stream, MSG_ERROR ) + $self->respond( Tangence::Message->new( $stream, MSG_ERROR ) ->pack_str( $msg ) ); } diff --git a/lib/Tangence/Stream.pm b/lib/Tangence/Stream.pm index a27d623..ca00280 100644 --- a/lib/Tangence/Stream.pm +++ b/lib/Tangence/Stream.pm @@ -3,10 +3,11 @@ # # (C) Paul Evans, 2011-2020 -- leonerd@leonerd.org.uk -package Tangence::Stream 0.26; +package Tangence::Stream 0.27; -use v5.14; +use v5.26; use warnings; +use experimental 'signatures'; use Carp; @@ -154,8 +155,15 @@ sub tangence_readfrom { my $self = shift; - while( my $message = Tangence::Message->try_new_from_bytes( $self, $_[0] ) ) { - my $code = $message->code; + while( length $_[0] ) { + last unless length $_[0] >= 5; + my ( $code, $len ) = unpack( "CN", $_[0] ); + last unless length $_[0] >= 5 + $len; + + substr( $_[0], 0, 5, "" ); + my $payload = substr( $_[0], 0, $len, "" ); + + my $message = Tangence::Message->new( $self, $code, $payload ); if( $code < 0x80 ) { push @{ $self->{request_queue} }, undef; @@ -185,11 +193,8 @@ sub tangence_readfrom } } -sub object_destroyed +sub object_destroyed ( $self, $obj, $startsub, $donesub ) { - my $self = shift; - my ( $obj, $startsub, $donesub ) = @_; - $startsub->(); my $objid = $obj->id; @@ -255,11 +260,8 @@ case. =cut -sub request +sub request ( $self, %args ) { - my $self = shift; - my %args = @_; - my $request = $args{request} or croak "Expected 'request'"; my $f; @@ -284,7 +286,10 @@ sub request push @{ $self->{responder_queue} }, $on_response; - $self->tangence_write( $request->bytes ); + my $payload = $request->payload; + $self->tangence_write( + pack "CNa*", $request->code, length($payload), $payload + ); return $f; } @@ -300,12 +305,10 @@ with the corresponding request. =cut -sub respond +sub respond ( $self, $token, $message ) { - my $self = shift; - my ( $token, $message ) = @_; - - my $response = $message->bytes; + my $payload = $message->payload; + my $response = pack "CNa*", $message->code, length($payload), $payload; $$token = $response; @@ -314,11 +317,8 @@ sub respond } } -sub respondERROR +sub respondERROR ( $self, $token, $string ) { - my $self = shift; - my ( $token, $string ) = @_; - $self->respond( $token, Tangence::Message->new( $self, MSG_ERROR ) ->pack_str( $string ) ); diff --git a/lib/Tangence/Struct.pm b/lib/Tangence/Struct.pm index 5573e63..dca41ae 100644 --- a/lib/Tangence/Struct.pm +++ b/lib/Tangence/Struct.pm @@ -1,13 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2012-2014 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2012-2021 -- leonerd@leonerd.org.uk -package Tangence::Struct 0.26; +use v5.26; +use Object::Pad 0.41; -use v5.14; -use warnings; -use base qw( Tangence::Meta::Struct ); +package Tangence::Struct 0.27; +class Tangence::Struct isa Tangence::Meta::Struct; use Carp; @@ -17,26 +17,15 @@ use Tangence::Meta::Field; our %STRUCTS_BY_NAME; our %STRUCTS_BY_PERLNAME; -sub new +sub make ( $class, %args ) { - my $class = shift; - my %args = @_; my $name = $args{name}; - return $STRUCTS_BY_NAME{$name} ||= $class->SUPER::new( @_ ); -} - -sub _new_type -{ - my ( $sig ) = @_; - return Tangence::Type->new_from_sig( $sig ); + return $STRUCTS_BY_NAME{$name} //= $class->new( %args ); } -sub declare +sub declare ( $class, $perlname, %args ) { - my $class = shift; - my ( $perlname, %args ) = @_; - ( my $name = $perlname ) =~ s{::}{.}g; $name = $args{name} if $args{name}; @@ -44,12 +33,12 @@ sub declare for( $_ = 0; $_ < @{$args{fields}}; $_ += 2 ) { push @fields, Tangence::Meta::Field->new( name => $args{fields}[$_], - type => Tangence::Type->new_from_sig( $args{fields}[$_+1] ), + type => Tangence::Type->make_from_sig( $args{fields}[$_+1] ), ); } - my $self = $class->new( name => $name ); - $self->{perlname} = $perlname; + my $self = $class->make( name => $name ); + $self->_set_perlname( $perlname ); $self->define( fields => \@fields, @@ -80,9 +69,7 @@ sub define # Now construct the actual perl package my %subs = ( - new => sub { - my $class = shift; - my %args = @_; + new => sub ( $class, %args ) { exists $args{$_} or croak "$class is missing $_" for @fieldnames; bless [ @args{@fieldnames} ], $class; }, @@ -96,27 +83,22 @@ sub define } } -sub for_name +sub for_name ( $class, $name ) { - my $class = shift; - my ( $name ) = @_; - - return $STRUCTS_BY_NAME{$name} || croak "Unknown Tangence::Struct for '$name'"; + return $STRUCTS_BY_NAME{$name} // croak "Unknown Tangence::Struct for '$name'"; } -sub for_perlname +sub for_perlname ( $class, $perlname ) { - my $class = shift; - my ( $perlname ) = @_; - - return $STRUCTS_BY_PERLNAME{$perlname} || croak "Unknown Tangence::Struct for '$perlname'"; + return $STRUCTS_BY_PERLNAME{$perlname} // croak "Unknown Tangence::Struct for '$perlname'"; } -sub perlname +has $perlname :writer(_set_perlname); + +method perlname { - my $self = shift; - return $self->{perlname} if $self->{perlname}; - ( my $perlname = $self->name ) =~ s{\.}{::}g; # s///rg in 5.14 + return $perlname if defined $perlname; + ( $perlname = $self->name ) =~ s{\.}{::}g; # s///rg in 5.14 return $perlname; } diff --git a/lib/Tangence/Type.pm b/lib/Tangence/Type.pm index df69699..0c3dfb9 100644 --- a/lib/Tangence/Type.pm +++ b/lib/Tangence/Type.pm @@ -1,16 +1,13 @@ # You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # -# (C) Paul Evans, 2013-2017 -- leonerd@leonerd.org.uk +# (C) Paul Evans, 2013-2021 -- leonerd@leonerd.org.uk -package Tangence::Type 0.26; +use v5.26; +use Object::Pad 0.41; -use v5.14; -use warnings; - -use base qw( Tangence::Meta::Type ); - -require Tangence::Type::Primitive; +package Tangence::Type 0.27; +class Tangence::Type isa Tangence::Meta::Type; =head1 NAME @@ -27,22 +24,22 @@ implementations. =head1 CONSTRUCTOR -=head2 new +=head2 make - $type = Tangence::Type->new( $primitive_sig ) + $type = Tangence::Type->make( $primitive_sig ) Returns an instance to represent a primitive type of the given signature. - $type = Tangence::Type->new( list => $member_type ) + $type = Tangence::Type->make( list => $member_type ) - $type = Tangence::Type->new( dict => $member_type ) + $type = Tangence::Type->make( dict => $member_type ) Returns an instance to represent a list or dict aggregation containing members of the given type. =cut -sub new +sub make { # Subtle trickery is at work here # Invoke our own superclass constructor, but pretend to be some higher @@ -52,20 +49,20 @@ sub new if( @_ == 1 ) { my ( $type ) = @_; my $class = "Tangence::Type::Primitive::$type"; - $class->can( "new" ) or die "TODO: Need $class"; + $class->can( "make" ) or die "TODO: Need $class"; - return $class->SUPER::new( $type ); + return $class->SUPER::make( $type ); } elsif( $_[0] eq "list" ) { shift; - return Tangence::Type::List->SUPER::new( list => @_ ); + return Tangence::Type::List->SUPER::make( list => @_ ); } elsif( $_[0] eq "dict" ) { shift; - return Tangence::Type::Dict->SUPER::new( dict => @_ ); + return Tangence::Type::Dict->SUPER::make( dict => @_ ); } else { - die "TODO: Not sure how to make a Tangence::Type->new( @_ )"; + die "TODO: Not sure how to make a Tangence::Type->make( @_ )"; } } @@ -91,84 +88,585 @@ Removes a value of this type from the start of a L<Tangence::Message>. =cut -package - Tangence::Type::List; -use base qw( Tangence::Type ); -use Carp; -use Tangence::Constants; +class Tangence::Type::List isa Tangence::Type +{ + use Carp; + use Tangence::Constants; + + method default_value { [] } + + method pack_value ( $message, $value ) + { + ref $value eq "ARRAY" or croak "Cannot pack a list from non-ARRAY reference"; + + $message->_pack_leader( DATA_LIST, scalar @$value ); + + my $member_type = $self->member_type; + $member_type->pack_value( $message, $_ ) for @$value; + } + + method unpack_value ( $message ) + { + my ( $type, $num ) = $message->_unpack_leader(); + $type == DATA_LIST or croak "Expected to unpack a list but did not find one"; -sub default_value { [] } + my $member_type = $self->member_type; + my @values; + foreach ( 1 .. $num ) { + push @values, $member_type->unpack_value( $message ); + } -sub pack_value + return \@values; + } +} + +class Tangence::Type::Dict isa Tangence::Type { - my $self = shift; - my ( $message, $value ) = @_; + use Carp; + use Tangence::Constants; + + method default_value { {} } + + method pack_value ( $message, $value ) + { + ref $value eq "HASH" or croak "Cannot pack a dict from non-HASH reference"; - ref $value eq "ARRAY" or croak "Cannot pack a list from non-ARRAY reference"; + my @keys = keys %$value; + @keys = sort @keys if $Tangence::Message::SORT_HASH_KEYS; - $message->_pack_leader( DATA_LIST, scalar @$value ); + $message->_pack_leader( DATA_DICT, scalar @keys ); - my $member_type = $self->member_type; - $member_type->pack_value( $message, $_ ) for @$value; + my $member_type = $self->member_type; + $message->pack_str( $_ ), $member_type->pack_value( $message, $value->{$_} ) for @keys; + } + + method unpack_value ( $message ) + { + my ( $type, $num ) = $message->_unpack_leader(); + $type == DATA_DICT or croak "Expected to unpack a dict but did not find one"; + + my $member_type = $self->member_type; + my %values; + foreach ( 1 .. $num ) { + my $key = $message->unpack_str(); + $values{$key} = $member_type->unpack_value( $message ); + } + + return \%values; + } } -sub unpack_value +class Tangence::Type::Primitive::bool isa Tangence::Type { - my $self = shift; - my ( $message ) = @_; + use Carp; + use Tangence::Constants; - my ( $type, $num ) = $message->_unpack_leader(); - $type == DATA_LIST or croak "Expected to unpack a list but did not find one"; + method default_value { "" } - my $member_type = $self->member_type; - my @values; - foreach ( 1 .. $num ) { - push @values, $member_type->unpack_value( $message ); + method pack_value ( $message, $value ) + { + $message->_pack_leader( DATA_NUMBER, $value ? DATANUM_BOOLTRUE : DATANUM_BOOLFALSE ); } - return \@values; + method unpack_value ( $message ) + { + my ( $type, $num ) = $message->_unpack_leader(); + + $type == DATA_NUMBER or croak "Expected to unpack a number(bool) but did not find one"; + $num == DATANUM_BOOLFALSE and return !!0; + $num == DATANUM_BOOLTRUE and return !!1; + croak "Expected to find a DATANUM_BOOL subtype but got $num"; + } } -package - Tangence::Type::Dict; -use base qw( Tangence::Type ); -use Carp; -use Tangence::Constants; +class Tangence::Type::Primitive::_integral isa Tangence::Type +{ + use Carp; + use Tangence::Constants; + + use constant SUBTYPE => undef; + + method default_value { 0 } + + my %format = ( + DATANUM_UINT8, [ "C", 1 ], + DATANUM_SINT8, [ "c", 1 ], + DATANUM_UINT16, [ "S>", 2 ], + DATANUM_SINT16, [ "s>", 2 ], + DATANUM_UINT32, [ "L>", 4 ], + DATANUM_SINT32, [ "l>", 4 ], + DATANUM_UINT64, [ "Q>", 8 ], + DATANUM_SINT64, [ "q>", 8 ], + ); + + sub _best_int_type_for ( $n ) + { + if( $n < 0 ) { + return DATANUM_SINT8 if $n >= -0x80; + return DATANUM_SINT16 if $n >= -0x8000; + return DATANUM_SINT32 if $n >= -0x80000000; + return DATANUM_SINT64; + } + + return DATANUM_UINT8 if $n <= 0xff; + return DATANUM_UINT16 if $n <= 0xffff; + return DATANUM_UINT32 if $n <= 0xffffffff; + return DATANUM_UINT64; + } + + method pack_value ( $message, $value ) + { + defined $value or croak "cannot pack_int(undef)"; + ref $value and croak "$value is not a number"; + $value == $value or croak "cannot pack_int(NaN)"; + $value == "+Inf" || $value == "-Inf" and croak "cannot pack_int(Inf)"; + + my $subtype = $self->SUBTYPE || _best_int_type_for( $value ); + $message->_pack_leader( DATA_NUMBER, $subtype ); + + $message->_pack( pack( $format{$subtype}[0], $value ) ); + } + + method unpack_value ( $message ) + { + my ( $type, $num ) = $message->_unpack_leader(); -sub default_value { {} } + $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one"; + exists $format{$num} or croak "Expected an integer subtype but got $num"; -sub pack_value + if( my $subtype = $self->SUBTYPE ) { + $subtype == $num or croak "Expected integer subtype $subtype, got $num"; + } + + my ( $n ) = unpack( $format{$num}[0], $message->_unpack( $format{$num}[1] ) ); + + return $n; + } +} + +class Tangence::Type::Primitive::u8 isa Tangence::Type::Primitive::_integral { - my $self = shift; - my ( $message, $value ) = @_; + use constant SUBTYPE => Tangence::Constants::DATANUM_UINT8; +} - ref $value eq "HASH" or croak "Cannot pack a dict from non-HASH reference"; +class Tangence::Type::Primitive::s8 isa Tangence::Type::Primitive::_integral +{ + use constant SUBTYPE => Tangence::Constants::DATANUM_SINT8; +} - my @keys = keys %$value; - @keys = sort @keys if $Tangence::Message::SORT_HASH_KEYS; +class Tangence::Type::Primitive::u16 isa Tangence::Type::Primitive::_integral +{ + use constant SUBTYPE => Tangence::Constants::DATANUM_UINT16; +} - $message->_pack_leader( DATA_DICT, scalar @keys ); +class Tangence::Type::Primitive::s16 isa Tangence::Type::Primitive::_integral +{ + use constant SUBTYPE => Tangence::Constants::DATANUM_SINT16; +} - my $member_type = $self->member_type; - $message->pack_str( $_ ), $member_type->pack_value( $message, $value->{$_} ) for @keys; +class Tangence::Type::Primitive::u32 isa Tangence::Type::Primitive::_integral +{ + use constant SUBTYPE => Tangence::Constants::DATANUM_UINT32; } -sub unpack_value +class Tangence::Type::Primitive::s32 isa Tangence::Type::Primitive::_integral { - my $self = shift; - my ( $message ) = @_; + use constant SUBTYPE => Tangence::Constants::DATANUM_SINT32; +} + +class Tangence::Type::Primitive::u64 isa Tangence::Type::Primitive::_integral +{ + use constant SUBTYPE => Tangence::Constants::DATANUM_UINT64; +} + +class Tangence::Type::Primitive::s64 isa Tangence::Type::Primitive::_integral +{ + use constant SUBTYPE => Tangence::Constants::DATANUM_SINT64; +} + +class Tangence::Type::Primitive::int isa Tangence::Type::Primitive::_integral +{ + # empty +} + +class Tangence::Type::Primitive::float isa Tangence::Type +{ + use Carp; + use Tangence::Constants; + + my $TYPE_FLOAT16 = Tangence::Type->make( 'float16' ); + + use constant SUBTYPE => undef; - my ( $type, $num ) = $message->_unpack_leader(); - $type == DATA_DICT or croak "Expected to unpack a dict but did not find one"; + method default_value { 0.0 } - my $member_type = $self->member_type; - my %values; - foreach ( 1 .. $num ) { - my $key = $message->unpack_str(); - $values{$key} = $member_type->unpack_value( $message ); + my %format = ( + # pack, bytes, NaN + DATANUM_FLOAT32, [ "f>", 4, "\x7f\xc0\x00\x00" ], + DATANUM_FLOAT64, [ "d>", 8, "\x7f\xf8\x00\x00\x00\x00\x00\x00" ], + ); + + sub _best_type_for ( $value ) + { + # Unpack as 64bit float and see if it's within limits + my $float64BIN = pack "d>", $value; + + # float64 == 1 / 11 / 52 + my $exp64 = ( unpack "L>", $float64BIN & "\x7f\xf0\x00\x00" ) >> (52-32); + + # Zero is smallest + return DATANUM_FLOAT16 if $exp64 == 0; + + # De-bias + $exp64 -= 1023; + + # Special values might as well be float16 + return DATANUM_FLOAT16 if $exp64 == 1024; + + # Smaller types are OK if the exponent will fit and there's no loss of + # mantissa precision + + return DATANUM_FLOAT16 if abs($exp64) < 15 && + ($float64BIN & "\x00\x00\x03\xff\xff\xff\xff\xff") eq "\x00"x8; + + return DATANUM_FLOAT32 if abs($exp64) < 127 && + ($float64BIN & "\x00\x00\x00\x00\x1f\xff\xff\xff") eq "\x00"x8; + + return DATANUM_FLOAT64; + } + + method pack_value ( $message, $value ) + { + defined $value or croak "cannot pack undef as float"; + ref $value and croak "$value is not a number"; + + my $subtype = $self->SUBTYPE || _best_type_for( $value ); + + return $TYPE_FLOAT16->pack_value( $message, $value ) if $subtype == DATANUM_FLOAT16; + + $message->_pack_leader( DATA_NUMBER, $subtype ); + $message->_pack( $value == $value ? + pack( $format{$subtype}[0], $value ) : $format{$subtype}[2] + ); + } + + method unpack_value ( $message ) + { + my ( $type, $num ) = $message->_unpack_leader( "peek" ); + + $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one"; + exists $format{$num} or $num == DATANUM_FLOAT16 or + croak "Expected a float subtype but got $num"; + + if( my $subtype = $self->SUBTYPE ) { + $subtype == $num or croak "Expected float subtype $subtype, got $num"; + } + + return $TYPE_FLOAT16->unpack_value( $message ) if $num == DATANUM_FLOAT16; + + $message->_unpack_leader; # no-peek + + my ( $n ) = unpack( $format{$num}[0], $message->_unpack( $format{$num}[1] ) ); + + return $n; + } +} + +class Tangence::Type::Primitive::float16 isa Tangence::Type::Primitive::float +{ + use Carp; + use Tangence::Constants; + + use constant SUBTYPE => DATANUM_FLOAT16; + + # TODO: This code doesn't correctly cope with Inf, -Inf or NaN + + method pack_value ( $message, $value ) + { + defined $value or croak "cannot pack undef as float"; + ref $value and croak "$value is not a number"; + + my $float32 = unpack( "N", pack "f>", $value ); + + # float32 == 1 / 8 / 23 + my $sign = ( $float32 & 0x80000000 ) >> 31; + my $exp = ( ( $float32 & 0x7f800000 ) >> 23 ) - 127; + my $mant32 = ( $float32 & 0x007fffff ); + + # float16 == 1 / 5 / 10 + my $mant16; + + if( $exp == 128 ) { + # special value - Inf or NaN + $exp = 16; + $mant16 = $mant32 ? (1 << 9) : 0; + $sign = 0 if $mant16; + } + elsif( $exp > 15 ) { + # Too large - become Inf + $exp = 16; + $mant16 = 0; + } + elsif( $exp > -15 ) { + $mant16 = $mant32 >> 13; + } + else { + # zero or subnormal - become zero + $exp = -15; + $mant16 = 0; + } + + my $float16 = $sign << 15 | + ( $exp + 15 ) << 10 | + $mant16; + + $message->_pack_leader( DATA_NUMBER, DATANUM_FLOAT16 ); + $message->_pack( pack "n", $float16 ); + } + + method unpack_value ( $message ) + { + my ( $type, $num ) = $message->_unpack_leader; + + $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one"; + $num == DATANUM_FLOAT16 or croak "Expected to unpack a float16 but found $num"; + + my $float16 = unpack "n", $message->_unpack( 2 ); + + # float16 == 1 / 5 / 10 + my $sign = ( $float16 & 0x8000 ) >> 15; + my $exp = ( ( $float16 & 0x7c00 ) >> 10 ) - 15; + my $mant16 = ( $float16 & 0x03ff ); + + # float32 == 1 / 8 / 23 + my $mant32; + + if( $exp == 16 ) { + # special value - Inf or NaN + $exp = 128; + $mant32 = $mant16 ? (1 << 22) : 0; + } + elsif( $exp > -15 ) { + $mant32 = $mant16 << 13; + } + else { + # zero + $exp = -127; + $mant32 = 0; + } + + my $float32 = $sign << 31 | + ( $exp + 127 ) << 23 | + $mant32; + + return unpack( "f>", pack "N", $float32 ); + } +} + +class Tangence::Type::Primitive::float32 isa Tangence::Type::Primitive::float +{ + use Tangence::Constants; + + use constant SUBTYPE => DATANUM_FLOAT32; +} + +class Tangence::Type::Primitive::float64 isa Tangence::Type::Primitive::float +{ + use Tangence::Constants; + + use constant SUBTYPE => DATANUM_FLOAT64; +} + +class Tangence::Type::Primitive::str isa Tangence::Type +{ + use Carp; + use Encode qw( encode_utf8 decode_utf8 ); + use Tangence::Constants; + + method default_value { "" } + + method pack_value ( $message, $value ) + { + defined $value or croak "cannot pack_str(undef)"; + ref $value and croak "$value is not a string"; + my $octets = encode_utf8( $value ); + $message->_pack_leader( DATA_STRING, length($octets) ); + $message->_pack( $octets ); } - return \%values; + method unpack_value ( $message ) + { + my ( $type, $num ) = $message->_unpack_leader(); + + $type == DATA_STRING or croak "Expected to unpack a string but did not find one"; + my $octets = $message->_unpack( $num ); + return decode_utf8( $octets ); + } +} + +class Tangence::Type::Primitive::obj isa Tangence::Type +{ + use Carp; + use Scalar::Util qw( blessed ); + use Tangence::Constants; + + method default_value { undef } + + method pack_value ( $message, $value ) + { + my $stream = $message->stream; + + if( !defined $value ) { + $message->_pack_leader( DATA_OBJECT, 0 ); + } + elsif( blessed $value and $value->isa( "Tangence::Object" ) ) { + my $id = $value->id; + my $preamble = ""; + + $value->{destroyed} and croak "Cannot pack destroyed object $value"; + + $message->packmeta_construct( $value ) unless $stream->peer_hasobj->{$id}; + + $message->_pack_leader( DATA_OBJECT, 4 ); + $message->_pack( pack( "N", $id ) ); + } + elsif( blessed $value and $value->isa( "Tangence::ObjectProxy" ) ) { + $message->_pack_leader( DATA_OBJECT, 4 ); + $message->_pack( pack( "N", $value->id ) ); + } + else { + croak "Do not know how to pack a " . ref($value); + } + } + + method unpack_value ( $message ) + { + my ( $type, $num ) = $message->_unpack_leader(); + + my $stream = $message->stream; + + $type == DATA_OBJECT or croak "Expected to unpack an object but did not find one"; + return undef unless $num; + if( $num == 4 ) { + my ( $id ) = unpack( "N", $message->_unpack( 4 ) ); + return $stream->get_by_id( $id ); + } + else { + croak "Unexpected number of bits to encode an OBJECT"; + } + } +} + +class Tangence::Type::Primitive::any isa Tangence::Type +{ + use Carp; + use Scalar::Util qw( blessed ); + use Tangence::Constants; + + use Syntax::Keyword::Match; + + use constant HAVE_ISBOOL => defined eval { Scalar::Util->import( 'isbool' ) }; + + my $TYPE_BOOL = Tangence::Type->make( 'bool' ); + my $TYPE_INT = Tangence::Type->make( 'int' ); + my $TYPE_FLOAT = Tangence::Type->make( 'float' ); + my $TYPE_STR = Tangence::Type->make( 'str' ); + my $TYPE_OBJ = Tangence::Type->make( 'obj' ); + my $TYPE_ANY = Tangence::Type->make( 'any' ); + + my $TYPE_LIST_ANY = Tangence::Type->make( list => $TYPE_ANY ); + my $TYPE_DICT_ANY = Tangence::Type->make( dict => $TYPE_ANY ); + + method default_value { undef } + + method pack_value ( $message, $value ) + { + if( !defined $value ) { + $TYPE_OBJ->pack_value( $message, undef ); + } + elsif( !ref $value ) { + no warnings 'numeric'; + + my $is_numeric = do { + my $tmp = $value; + + # use X^X operator to distinguish actual numbers from strings + # If $tmp contains any non-ASCII bytes the it's definitely not a + # decimal representation of a number + $tmp =~ m/^[[:ascii:]]+$/ and ( $value ^ $value ) eq "0" + }; + + if( HAVE_ISBOOL && Scalar::Util::isbool($value) ) { + $TYPE_BOOL->pack_value( $message, $value ); + } + # test for integers, but exclude NaN + elsif( int($value) eq $value and $value == $value ) { + $TYPE_INT->pack_value( $message, $value ); + } + elsif( $message->stream->_ver_can_num_float and $is_numeric ) { + $TYPE_FLOAT->pack_value( $message, $value ); + } + else { + $TYPE_STR->pack_value( $message, $value ); + } + } + elsif( blessed $value and $value->isa( "Tangence::Object" ) || $value->isa( "Tangence::ObjectProxy" ) ) { + $TYPE_OBJ->pack_value( $message, $value ); + } + elsif( my $struct = eval { Tangence::Struct->for_perlname( ref $value ) } ) { + $message->pack_record( $value, $struct ); + } + elsif( ref $value eq "ARRAY" ) { + $TYPE_LIST_ANY->pack_value( $message, $value ); + } + elsif( ref $value eq "HASH" ) { + $TYPE_DICT_ANY->pack_value( $message, $value ); + } + else { + croak "Do not know how to pack a " . ref($value); + } + } + + method unpack_value ( $message ) + { + my $type = $message->_peek_leader_type(); + + match( $type : == ) { + case( DATA_NUMBER ) { + my ( undef, $num ) = $message->_unpack_leader( "peek" ); + if( $num >= DATANUM_BOOLFALSE and $num <= DATANUM_BOOLTRUE ) { + return $TYPE_BOOL->unpack_value( $message ); + } + elsif( $num >= DATANUM_UINT8 and $num <= DATANUM_SINT64 ) { + return $TYPE_INT->unpack_value( $message ); + } + elsif( $num >= DATANUM_FLOAT16 and $num <= DATANUM_FLOAT64 ) { + return $TYPE_FLOAT->unpack_value( $message ); + } + else { + croak "Do not know how to unpack DATA_NUMBER subtype $num"; + } + } + case( DATA_STRING ) { + return $TYPE_STR->unpack_value( $message ); + } + case( DATA_OBJECT ) { + return $TYPE_OBJ->unpack_value( $message ); + } + case( DATA_LIST ) { + return $TYPE_LIST_ANY->unpack_value( $message ); + } + case( DATA_DICT ) { + return $TYPE_DICT_ANY->unpack_value( $message ); + } + case( DATA_RECORD ) { + return $message->unpack_record( undef ); + } + default { + croak "Do not know how to unpack record of type $type"; + } + } + } } =head1 AUTHOR diff --git a/lib/Tangence/Type/Primitive.pm b/lib/Tangence/Type/Primitive.pm deleted file mode 100644 index 2c8311a..0000000 --- a/lib/Tangence/Type/Primitive.pm +++ /dev/null @@ -1,578 +0,0 @@ -# You may distribute under the terms of either the GNU General Public License -# or the Artistic License (the same terms as Perl itself) -# -# (C) Paul Evans, 2013-2016 -- leonerd@leonerd.org.uk - -package Tangence::Type::Primitive 0.26; - -use v5.14; -use warnings; - -use base qw( Tangence::Type ); - -package - Tangence::Type::Primitive::bool; -use base qw( Tangence::Type::Primitive ); -use Carp; -use Tangence::Constants; - -sub default_value { "" } - -sub pack_value -{ - my $self = shift; - my ( $message, $value ) = @_; - - $message->_pack_leader( DATA_NUMBER, $value ? DATANUM_BOOLTRUE : DATANUM_BOOLFALSE ); -} - -sub unpack_value -{ - my $self = shift; - my ( $message ) = @_; - - my ( $type, $num ) = $message->_unpack_leader(); - - $type == DATA_NUMBER or croak "Expected to unpack a number(bool) but did not find one"; - $num == DATANUM_BOOLFALSE and return !!0; - $num == DATANUM_BOOLTRUE and return !!1; - croak "Expected to find a DATANUM_BOOL subtype but got $num"; -} - -package - Tangence::Type::Primitive::_integral; -use base qw( Tangence::Type::Primitive ); -use Carp; -use Tangence::Constants; - -use constant SUBTYPE => undef; - -sub default_value { 0 } - -{ - my %format = ( - DATANUM_UINT8, [ "C", 1 ], - DATANUM_SINT8, [ "c", 1 ], - DATANUM_UINT16, [ "S>", 2 ], - DATANUM_SINT16, [ "s>", 2 ], - DATANUM_UINT32, [ "L>", 4 ], - DATANUM_SINT32, [ "l>", 4 ], - DATANUM_UINT64, [ "Q>", 8 ], - DATANUM_SINT64, [ "q>", 8 ], - ); - - sub _best_int_type_for - { - my ( $n ) = @_; - - if( $n < 0 ) { - return DATANUM_SINT8 if $n >= -0x80; - return DATANUM_SINT16 if $n >= -0x8000; - return DATANUM_SINT32 if $n >= -0x80000000; - return DATANUM_SINT64; - } - - return DATANUM_UINT8 if $n <= 0xff; - return DATANUM_UINT16 if $n <= 0xffff; - return DATANUM_UINT32 if $n <= 0xffffffff; - return DATANUM_UINT64; - } - - sub pack_value - { - my $self = shift; - my ( $message, $value ) = @_; - - defined $value or croak "cannot pack_int(undef)"; - ref $value and croak "$value is not a number"; - $value == $value or croak "cannot pack_int(NaN)"; - $value == "+Inf" || $value == "-Inf" and croak "cannot pack_int(Inf)"; - - my $subtype = $self->SUBTYPE || _best_int_type_for( $value ); - $message->_pack_leader( DATA_NUMBER, $subtype ); - - $message->_pack( pack( $format{$subtype}[0], $value ) ); - } - - sub unpack_value - { - my $self = shift; - my ( $message ) = @_; - - my ( $type, $num ) = $message->_unpack_leader(); - - $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one"; - exists $format{$num} or croak "Expected an integer subtype but got $num"; - - if( my $subtype = $self->SUBTYPE ) { - $subtype == $num or croak "Expected integer subtype $subtype, got $num"; - } - - my ( $n ) = unpack( $format{$num}[0], $message->_unpack( $format{$num}[1] ) ); - - return $n; - } -} - -package - Tangence::Type::Primitive::u8; -use base qw( Tangence::Type::Primitive::_integral ); -use constant SUBTYPE => Tangence::Constants::DATANUM_UINT8; - -package - Tangence::Type::Primitive::s8; -use base qw( Tangence::Type::Primitive::_integral ); -use constant SUBTYPE => Tangence::Constants::DATANUM_SINT8; - -package - Tangence::Type::Primitive::u16; -use base qw( Tangence::Type::Primitive::_integral ); -use constant SUBTYPE => Tangence::Constants::DATANUM_UINT16; - -package - Tangence::Type::Primitive::s16; -use base qw( Tangence::Type::Primitive::_integral ); -use constant SUBTYPE => Tangence::Constants::DATANUM_SINT16; - -package - Tangence::Type::Primitive::u32; -use base qw( Tangence::Type::Primitive::_integral ); -use constant SUBTYPE => Tangence::Constants::DATANUM_UINT32; - -package - Tangence::Type::Primitive::s32; -use base qw( Tangence::Type::Primitive::_integral ); -use constant SUBTYPE => Tangence::Constants::DATANUM_SINT32; - -package - Tangence::Type::Primitive::u64; -use base qw( Tangence::Type::Primitive::_integral ); -use constant SUBTYPE => Tangence::Constants::DATANUM_UINT64; - -package - Tangence::Type::Primitive::s64; -use base qw( Tangence::Type::Primitive::_integral ); -use constant SUBTYPE => Tangence::Constants::DATANUM_SINT64; - -package - Tangence::Type::Primitive::int; -use base qw( Tangence::Type::Primitive::_integral ); - -package - Tangence::Type::Primitive::float; -use base qw( Tangence::Type::Primitive ); -use Carp; -use Tangence::Constants; - -use constant SUBTYPE => undef; - -sub default_value { 0.0 } - -{ - my %format = ( - # pack, bytes, NaN - DATANUM_FLOAT32, [ "f>", 4, "\x7f\xc0\x00\x00" ], - DATANUM_FLOAT64, [ "d>", 8, "\x7f\xf8\x00\x00\x00\x00\x00\x00" ], - ); - - sub _best_type_for - { - my ( $value ) = @_; - - # Unpack as 64bit float and see if it's within limits - my $float64BIN = pack "d>", $value; - - # float64 == 1 / 11 / 52 - my $exp64 = ( unpack "L>", $float64BIN & "\x7f\xf0\x00\x00" ) >> (52-32); - - # Zero is smallest - return DATANUM_FLOAT16 if $exp64 == 0; - - # De-bias - $exp64 -= 1023; - - # Special values might as well be float16 - return DATANUM_FLOAT16 if $exp64 == 1024; - - # Smaller types are OK if the exponent will fit and there's no loss of - # mantissa precision - - return DATANUM_FLOAT16 if abs($exp64) < 15 && - ($float64BIN & "\x00\x00\x03\xff\xff\xff\xff\xff") eq "\x00"x8; - - return DATANUM_FLOAT32 if abs($exp64) < 127 && - ($float64BIN & "\x00\x00\x00\x00\x1f\xff\xff\xff") eq "\x00"x8; - - return DATANUM_FLOAT64; - } - - sub pack_value - { - my $self = shift; - my ( $message, $value ) = @_; - - defined $value or croak "cannot pack undef as float"; - ref $value and croak "$value is not a number"; - - my $subtype = $self->SUBTYPE || _best_type_for( $value ); - - return Tangence::Type::Primitive::float16->pack_value( $message, $value ) if $subtype == DATANUM_FLOAT16; - - $message->_pack_leader( DATA_NUMBER, $subtype ); - $message->_pack( $value == $value ? - pack( $format{$subtype}[0], $value ) : $format{$subtype}[2] - ); - } - - sub unpack_value - { - my $self = shift; - my ( $message ) = @_; - - my ( $type, $num ) = $message->_unpack_leader( "peek" ); - - $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one"; - exists $format{$num} or $num == DATANUM_FLOAT16 or - croak "Expected a float subtype but got $num"; - - if( my $subtype = $self->SUBTYPE ) { - $subtype == $num or croak "Expected float subtype $subtype, got $num"; - } - - return Tangence::Type::Primitive::float16->unpack_value( $message ) if $num == DATANUM_FLOAT16; - - $message->_unpack_leader; # no-peek - - my ( $n ) = unpack( $format{$num}[0], $message->_unpack( $format{$num}[1] ) ); - - return $n; - } -} - -package - Tangence::Type::Primitive::float16; -use base qw( Tangence::Type::Primitive::float ); -use Carp; -use Tangence::Constants; - -use constant SUBTYPE => DATANUM_FLOAT16; - -# TODO: This code doesn't correctly cope with Inf, -Inf or NaN - -sub pack_value -{ - my $self = shift; - my ( $message, $value ) = @_; - - defined $value or croak "cannot pack undef as float"; - ref $value and croak "$value is not a number"; - - my $float32 = unpack( "N", pack "f>", $value ); - - # float32 == 1 / 8 / 23 - my $sign = ( $float32 & 0x80000000 ) >> 31; - my $exp = ( ( $float32 & 0x7f800000 ) >> 23 ) - 127; - my $mant32 = ( $float32 & 0x007fffff ); - - # float16 == 1 / 5 / 10 - my $mant16; - - if( $exp == 128 ) { - # special value - Inf or NaN - $exp = 16; - $mant16 = $mant32 ? (1 << 9) : 0; - $sign = 0 if $mant16; - } - elsif( $exp > 15 ) { - # Too large - become Inf - $exp = 16; - $mant16 = 0; - } - elsif( $exp > -15 ) { - $mant16 = $mant32 >> 13; - } - else { - # zero or subnormal - become zero - $exp = -15; - $mant16 = 0; - } - - my $float16 = $sign << 15 | - ( $exp + 15 ) << 10 | - $mant16; - - $message->_pack_leader( DATA_NUMBER, DATANUM_FLOAT16 ); - $message->_pack( pack "n", $float16 ); -} - -sub unpack_value -{ - my $self = shift; - my ( $message ) = @_; - - my ( $type, $num ) = $message->_unpack_leader; - - $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one"; - $num == DATANUM_FLOAT16 or croak "Expected to unpack a float16 but found $num"; - - my $float16 = unpack "n", $message->_unpack( 2 ); - - # float16 == 1 / 5 / 10 - my $sign = ( $float16 & 0x8000 ) >> 15; - my $exp = ( ( $float16 & 0x7c00 ) >> 10 ) - 15; - my $mant16 = ( $float16 & 0x03ff ); - - # float32 == 1 / 8 / 23 - my $mant32; - - if( $exp == 16 ) { - # special value - Inf or NaN - $exp = 128; - $mant32 = $mant16 ? (1 << 22) : 0; - } - elsif( $exp > -15 ) { - $mant32 = $mant16 << 13; - } - else { - # zero - $exp = -127; - $mant32 = 0; - } - - my $float32 = $sign << 31 | - ( $exp + 127 ) << 23 | - $mant32; - - return unpack( "f>", pack "N", $float32 ); -} - -package - Tangence::Type::Primitive::float32; -use base qw( Tangence::Type::Primitive::float ); -use Tangence::Constants; - -use constant SUBTYPE => DATANUM_FLOAT32; - -package - Tangence::Type::Primitive::float64; -use base qw( Tangence::Type::Primitive::float ); -use Tangence::Constants; - -use constant SUBTYPE => DATANUM_FLOAT64; - -package - Tangence::Type::Primitive::str; -use base qw( Tangence::Type::Primitive ); -use Carp; -use Encode qw( encode_utf8 decode_utf8 ); -use Tangence::Constants; - -sub default_value { "" } - -sub pack_value -{ - my $self = shift; - my ( $message, $value ) = @_; - - defined $value or croak "cannot pack_str(undef)"; - ref $value and croak "$value is not a string"; - my $octets = encode_utf8( $value ); - $message->_pack_leader( DATA_STRING, length($octets) ); - $message->_pack( $octets ); -} - -sub unpack_value -{ - my $self = shift; - my ( $message ) = @_; - - my ( $type, $num ) = $message->_unpack_leader(); - - $type == DATA_STRING or croak "Expected to unpack a string but did not find one"; - my $octets = $message->_unpack( $num ); - return decode_utf8( $octets ); -} - -package - Tangence::Type::Primitive::obj; -use base qw( Tangence::Type::Primitive ); -use Carp; -use Scalar::Util qw( blessed ); -use Tangence::Constants; - -sub default_value { undef } - -sub pack_value -{ - my $self = shift; - my ( $message, $value ) = @_; - - my $stream = $message->stream; - - if( !defined $value ) { - $message->_pack_leader( DATA_OBJECT, 0 ); - } - elsif( blessed $value and $value->isa( "Tangence::Object" ) ) { - my $id = $value->id; - my $preamble = ""; - - $value->{destroyed} and croak "Cannot pack destroyed object $value"; - - $message->packmeta_construct( $value ) unless $stream->peer_hasobj->{$id}; - - $message->_pack_leader( DATA_OBJECT, 4 ); - $message->_pack( pack( "N", $id ) ); - } - elsif( blessed $value and $value->isa( "Tangence::ObjectProxy" ) ) { - $message->_pack_leader( DATA_OBJECT, 4 ); - $message->_pack( pack( "N", $value->id ) ); - } - else { - croak "Do not know how to pack a " . ref($value); - } -} - -sub unpack_value -{ - my $self = shift; - my ( $message ) = @_; - - my ( $type, $num ) = $message->_unpack_leader(); - - my $stream = $message->stream; - - $type == DATA_OBJECT or croak "Expected to unpack an object but did not find one"; - return undef unless $num; - if( $num == 4 ) { - my ( $id ) = unpack( "N", $message->_unpack( 4 ) ); - return $stream->get_by_id( $id ); - } - else { - croak "Unexpected number of bits to encode an OBJECT"; - } -} - -package - Tangence::Type::Primitive::any; -use base qw( Tangence::Type::Primitive ); -use Carp; -use Scalar::Util qw( blessed ); -use Tangence::Constants; - -use constant HAVE_ISBOOL => defined eval { Scalar::Util->import( 'isbool' ) }; - -# We can't use Tangence::Types here without a dependency cycle -# However, it's OK to create even TYPE_ANY right here, because the 'any' class -# now exists. -use constant TYPE_BOOL => Tangence::Type->new( 'bool' ); -use constant TYPE_INT => Tangence::Type->new( 'int' ); -use constant TYPE_FLOAT => Tangence::Type->new( 'float' ); -use constant TYPE_STR => Tangence::Type->new( 'str' ); -use constant TYPE_OBJ => Tangence::Type->new( 'obj' ); -use constant TYPE_ANY => Tangence::Type->new( 'any' ); - -use constant TYPE_LIST_ANY => Tangence::Type->new( list => TYPE_ANY ); -use constant TYPE_DICT_ANY => Tangence::Type->new( dict => TYPE_ANY ); - -sub default_value { undef } - -sub pack_value -{ - my $self = shift; - my ( $message, $value ) = @_; - - if( !defined $value ) { - TYPE_OBJ->pack_value( $message, undef ); - } - elsif( !ref $value ) { - no warnings 'numeric'; - - my $is_numeric = do { - my $tmp = $value; - - # use X^X operator to distinguish actual numbers from strings - # If $tmp contains any non-ASCII bytes the it's definitely not a - # decimal representation of a number - $tmp =~ m/^[[:ascii:]]+$/ and ( $value ^ $value ) eq "0" - }; - - if( HAVE_ISBOOL && Scalar::Util::isbool($value) ) { - TYPE_BOOL->pack_value( $message, $value ); - } - # test for integers, but exclude NaN - elsif( int($value) eq $value and $value == $value ) { - TYPE_INT->pack_value( $message, $value ); - } - elsif( $message->stream->_ver_can_num_float and $is_numeric ) { - TYPE_FLOAT->pack_value( $message, $value ); - } - else { - TYPE_STR->pack_value( $message, $value ); - } - } - elsif( blessed $value and $value->isa( "Tangence::Object" ) || $value->isa( "Tangence::ObjectProxy" ) ) { - TYPE_OBJ->pack_value( $message, $value ); - } - elsif( my $struct = eval { Tangence::Struct->for_perlname( ref $value ) } ) { - $message->pack_record( $value, $struct ); - } - elsif( ref $value eq "ARRAY" ) { - TYPE_LIST_ANY->pack_value( $message, $value ); - } - elsif( ref $value eq "HASH" ) { - TYPE_DICT_ANY->pack_value( $message, $value ); - } - else { - croak "Do not know how to pack a " . ref($value); - } -} - -sub unpack_value -{ - my $self = shift; - my ( $message ) = @_; - - my $type = $message->_peek_leader_type(); - - if( $type == DATA_NUMBER ) { - my ( undef, $num ) = $message->_unpack_leader( "peek" ); - if( $num >= DATANUM_BOOLFALSE and $num <= DATANUM_BOOLTRUE ) { - return TYPE_BOOL->unpack_value( $message ); - } - elsif( $num >= DATANUM_UINT8 and $num <= DATANUM_SINT64 ) { - return TYPE_INT->unpack_value( $message ); - } - elsif( $num >= DATANUM_FLOAT16 and $num <= DATANUM_FLOAT64 ) { - return TYPE_FLOAT->unpack_value( $message ); - } - else { - croak "Do not know how to unpack DATA_NUMBER subtype $num"; - } - } - if( $type == DATA_STRING ) { - return TYPE_STR->unpack_value( $message ); - } - elsif( $type == DATA_OBJECT ) { - return TYPE_OBJ->unpack_value( $message ); - } - elsif( $type == DATA_LIST ) { - return TYPE_LIST_ANY->unpack_value( $message ); - } - elsif( $type == DATA_DICT ) { - return TYPE_DICT_ANY->unpack_value( $message ); - } - elsif( $type == DATA_RECORD ) { - return $message->unpack_record( undef ); - } - else { - croak "Do not know how to unpack record of type $type"; - } -} - -=head1 AUTHOR - -Paul Evans <leonerd@leonerd.org.uk> - -=cut - -0x55AA; diff --git a/lib/Tangence/Types.pm b/lib/Tangence/Types.pm index 251f896..e2ca9b7 100644 --- a/lib/Tangence/Types.pm +++ b/lib/Tangence/Types.pm @@ -3,9 +3,9 @@ # # (C) Paul Evans, 2014 -- leonerd@leonerd.org.uk -package Tangence::Types 0.26; +package Tangence::Types 0.27; -use v5.14; +use v5.26; use warnings; use Exporter 'import'; @@ -25,16 +25,16 @@ our @EXPORT = qw( use Tangence::Type; -use constant TYPE_BOOL => Tangence::Type->new( "bool" ); -use constant TYPE_U8 => Tangence::Type->new( "u8" ); -use constant TYPE_INT => Tangence::Type->new( "int" ); -use constant TYPE_STR => Tangence::Type->new( "str" ); -use constant TYPE_OBJ => Tangence::Type->new( "obj" ); -use constant TYPE_ANY => Tangence::Type->new( "any" ); +use constant TYPE_BOOL => Tangence::Type->make( "bool" ); +use constant TYPE_U8 => Tangence::Type->make( "u8" ); +use constant TYPE_INT => Tangence::Type->make( "int" ); +use constant TYPE_STR => Tangence::Type->make( "str" ); +use constant TYPE_OBJ => Tangence::Type->make( "obj" ); +use constant TYPE_ANY => Tangence::Type->make( "any" ); -use constant TYPE_LIST_STR => Tangence::Type->new( list => TYPE_STR ); -use constant TYPE_LIST_ANY => Tangence::Type->new( list => TYPE_ANY ); +use constant TYPE_LIST_STR => Tangence::Type->make( list => TYPE_STR ); +use constant TYPE_LIST_ANY => Tangence::Type->make( list => TYPE_ANY ); -use constant TYPE_DICT_ANY => Tangence::Type->new( dict => TYPE_ANY ); +use constant TYPE_DICT_ANY => Tangence::Type->make( dict => TYPE_ANY ); 0x55AA; @@ -1,6 +1,6 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; use Test::More; diff --git a/t/01compiler-parser.t b/t/01compiler-parser.t index 5b21a15..4bc40ee 100644 --- a/t/01compiler-parser.t +++ b/t/01compiler-parser.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; use Test::More; diff --git a/t/02registry.t b/t/02registry.t index bee7ba4..5a76009 100644 --- a/t/02registry.t +++ b/t/02registry.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; use Test::More; diff --git a/t/03properties.t b/t/03properties.t index bc7b124..ffe45bc 100644 --- a/t/03properties.t +++ b/t/03properties.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; use Test::More; diff --git a/t/10message.t b/t/10message.t index bfb4349..775d64c 100644 --- a/t/10message.t +++ b/t/10message.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; use Test::More; @@ -11,7 +11,7 @@ use Tangence::Message; $Tangence::Message::SORT_HASH_KEYS = 1; use Tangence::Type; -sub _make_type { Tangence::Type->new_from_sig( shift ) } +sub _make_type { Tangence::Type->make_from_sig( shift ) } use lib "."; use t::Colourable; @@ -49,15 +49,15 @@ sub test_specific my $name = shift; my %args = @_; - my $m = Tangence::Message->new( TestStream->new ); + my $m = Tangence::Message->new( TestStream->new, undef ); my $pack_method = "pack_$args{type}"; is( $m->$pack_method( $args{data} ), $m, "$pack_method returns \$m for $name" ); - is_hexstr( $m->{record}, $args{stream}, "$pack_method $name" ); + is_hexstr( $m->payload, $args{stream}, "$pack_method $name" ); my $unpack_method = "unpack_$args{type}"; is_deeply( $m->$unpack_method(), exists $args{retdata} ? $args{retdata} : $args{data}, "$unpack_method $name" ); - is( length $m->{record}, 0, "eats all stream for $name" ); + is( length $m->payload, 0, "eats all stream for $name" ); } sub test_specific_dies @@ -66,7 +66,7 @@ sub test_specific_dies my %args = @_; ok( exception { - my $m = Tangence::Message->new( TestStream->new ); + my $m = Tangence::Message->new( TestStream->new, undef ); my $pack_method = "pack_$args{type}"; $m->$pack_method( $args{data} ); @@ -202,10 +202,10 @@ sub test_typed my $type = _make_type $args{sig}; - my $m = Tangence::Message->new( TestStream->new ); + my $m = Tangence::Message->new( TestStream->new, undef ); $type->pack_value( $m, $args{data} ); - is_hexstr( $m->{record}, $args{stream}, "pack typed $name" ); + is_hexstr( $m->payload, $args{stream}, "pack typed $name" ); my $value = $type->unpack_value( $m ); my $expect = exists $args{retdata} ? $args{retdata} : $args{data}; @@ -221,7 +221,7 @@ sub test_typed } is_deeply( $value, $expect, "\$type->unpack_value $name" ); - is( length $m->{record}, 0, "eats all stream for $name" ); + is( length $m->payload, 0, "eats all stream for $name" ); } sub test_typed_dies @@ -233,7 +233,7 @@ sub test_typed_dies my $type = _make_type $sig; ok( exception { - my $m = Tangence::Message->new( TestStream->new ); + my $m = Tangence::Message->new( TestStream->new, undef ); $type->pack_value( $m, $args{data} ); }, "\$type->pack_value for ($sig) $name dies" ) if exists $args{data}; @@ -581,12 +581,12 @@ test_typed "any (record)", my $m; -$m = Tangence::Message->new( 0 ); +$m = Tangence::Message->new( 0, undef ); $m->pack_all_sametype( _make_type('int'), 10, 20, 30 ); -is_hexstr( $m->{record}, "\x02\x0a\x02\x14\x02\x1e", 'pack_all_sametype' ); +is_hexstr( $m->payload, "\x02\x0a\x02\x14\x02\x1e", 'pack_all_sametype' ); is_deeply( [ $m->unpack_all_sametype( _make_type('int') ) ], [ 10, 20, 30 ], 'unpack_all_sametype' ); -is( length $m->{record}, 0, "eats all stream for all_sametype" ); +is( length $m->payload, 0, "eats all stream for all_sametype" ); done_testing; diff --git a/t/11stream.t b/t/11stream.t index c21f114..fe53db4 100644 --- a/t/11stream.t +++ b/t/11stream.t @@ -1,8 +1,10 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; +use Future::AsyncAwait 0.47; + use Test::More; use Test::HexString; @@ -76,7 +78,7 @@ isa_ok( $stream, "Tangence::Stream", '$stream isa Tangence::Stream' ); ok( $f->is_ready, '$f is ready after response' ); - my $response = $f->get; + my $response = await $f; is( $response->code, MSG_RESULT, '$response->code to initial call' ); is( $response->unpack_str, "response", '$response->unpack_str to initial call' ); diff --git a/t/20server.t b/t/20server.t index 5898ec5..88be531 100644 --- a/t/20server.t +++ b/t/20server.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; use Test::More; diff --git a/t/21client.t b/t/21client.t index d70b5e4..2549308 100644 --- a/t/21client.t +++ b/t/21client.t @@ -1,8 +1,10 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; +use Future::AsyncAwait 0.47; + use Test::More; use Test::Fatal; use Test::HexString; @@ -90,7 +92,7 @@ my $bagproxy; $client->send_message( $S2C{CALL} ); ok( $f->is_ready, '$f ready after MSG_RESULT' ); - is( scalar $f->get, "10/hello", 'result of call_method()' ); + is( scalar await $f, "10/hello", 'result of call_method()' ); $f = $objproxy->call_method( noreturn => ); @@ -98,7 +100,7 @@ my $bagproxy; $client->send_message( $S2C{CALL_NORETURN} ); - ok( exception { $objproxy->call_method( no_such_method => 123 ) }, + ok( exception { $objproxy->call_method( no_such_method => 123 )->get }, 'Calling no_such_method fails in proxy' ); } @@ -139,7 +141,7 @@ my $bagproxy; ok( exception { $objproxy->subscribe_event( "no_such_event", on_fire => sub {}, - ); }, + )->get; }, 'Subscribing to no_such_event fails in proxy' ); } @@ -162,7 +164,7 @@ my $bagproxy; $client->send_message( $S2C{GETPROP_123} ); ok( $f->is_ready, '$f is ready after MSG_RESULT' ); - is( scalar $f->get, 123, '$f->get after get_property' ); + is( scalar await $f, 123, 'await $f after get_property' ); $f = $objproxy->get_property_element( "hash", "two" ); @@ -171,7 +173,7 @@ my $bagproxy; $client->send_message( $S2C{GETPROPELEM_HASH} ); ok( $f->is_ready, '$f is ready after MSG_RESULT' ); - is( scalar $f->get, 2, '$f->get after get_property_element hash key' ); + is( scalar await $f, 2, 'await $f after get_property_element hash key' ); $f = $objproxy->get_property_element( "array", 1 ); @@ -180,7 +182,7 @@ my $bagproxy; $client->send_message( $S2C{GETPROPELEM_ARRAY} ); ok( $f->is_ready, '$f is ready after MSG_RESULT' ); - is( scalar $f->get, 2, '$f->get after get_property_element array index' ); + is( scalar await $f, 2, 'await $f after get_property_element array index' ); $f = $objproxy->set_property( "scalar", 135 ); @@ -238,7 +240,7 @@ my $bagproxy; $client->send_message( $MSG_OK ); - ok( exception { $objproxy->get_property( "no_such_property" ) }, + ok( exception { $objproxy->get_property( "no_such_property" )->get }, 'Getting no_such_property fails in proxy' ); } @@ -258,7 +260,7 @@ my $bagproxy; ok( $f->is_ready, '$f is ready after MSG_WATCHING_ITER' ); - my ( $cursor, $first_idx, $last_idx ) = $f->get; + my ( $cursor, $first_idx, $last_idx ) = await $f; is( $first_idx, 0, '$first_idx after MSG_WATCHING_ITER' ); is( $last_idx, 2, '$last_idx after MSG_WATCHING_ITER' ); @@ -269,7 +271,7 @@ my $bagproxy; $client->send_message( $S2C{ITER_NEXT_1} ); - my ( $idx, @more ) = $f->get; + my ( $idx, @more ) = await $f; is( $idx, 0, 'next_forward starts at element 0' ); is_deeply( \@more, [ 1 ], 'next_forward yielded 1 element' ); @@ -281,7 +283,7 @@ my $bagproxy; $client->send_message( $S2C{ITER_NEXT_5} ); - ( $idx, @more ) = $f->get; + ( $idx, @more ) = await $f; is( $idx, 1, 'next_forward starts at element 1' ); is_deeply( \@more, [ 2, 3 ], 'next_forward yielded 2 elements' ); @@ -293,7 +295,7 @@ my $bagproxy; $client->send_message( $S2C{ITER_NEXT_BACK} ); - ( $idx, @more ) = $f->get; + ( $idx, @more ) = await $f; is( $idx, 2, 'next_backward starts at element 2' ); is_deeply( \@more, [ 3 ], 'next_forward yielded 1 element' ); @@ -328,9 +330,9 @@ my $bagproxy; # Test object destruction { my $proxy_destroyed = 0; - $objproxy->subscribe_event( "destroy", + await $objproxy->subscribe_event( "destroy", on_fire => sub { $proxy_destroyed = 1 }, - )->get; + ); $client->send_message( $S2C{DESTROY} ); diff --git a/t/22xlink.t b/t/22xlink.t index 7bdc208..a027b1a 100644 --- a/t/22xlink.t +++ b/t/22xlink.t @@ -1,8 +1,10 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; +use Future::AsyncAwait 0.47; + use Test::More; use Test::Fatal; use Test::Refcount; @@ -44,9 +46,9 @@ my $objproxy = $client->rootobj; my $f = $objproxy->call_method( method => 10, "hello" ); ok( $f->is_ready, '$f ready after MSG_RESULT' ); - is( scalar $f->get, "10/hello", 'result of call_method()' ); + is( scalar await $f, "10/hello", 'result of call_method()' ); - ok( exception { $objproxy->call_method( no_such_method => 123 ) }, + ok( exception { $objproxy->call_method( no_such_method => 123 )->get }, 'Calling no_such_method fails in proxy' ); } @@ -77,7 +79,7 @@ my $objproxy = $client->rootobj; ok( exception { $objproxy->subscribe_event( "no_such_event", on_fire => sub {}, - ); }, + )->get; }, 'Subscribing to no_such_event fails in proxy' ); } @@ -95,15 +97,15 @@ my $objproxy = $client->rootobj; my $f = $objproxy->get_property( "scalar" ); - is( scalar $f->get, 123, '$f->get after get_property' ); + is( scalar await $f, 123, 'await $f after get_property' ); $f = $objproxy->get_property_element( "hash", "two" ); - is( scalar $f->get, 2, '$f->get after get_property_element hash key' ); + is( scalar await $f, 2, 'await $f after get_property_element hash key' ); $f = $objproxy->get_property_element( "array", 1 ); - is( scalar $f->get, 2, '$f->get after get_property_element array index' ); + is( scalar await $f, 2, 'await $f after get_property_element array index' ); $f = $objproxy->set_property( "scalar", 135 ); @@ -140,7 +142,7 @@ my $objproxy = $client->rootobj; $objproxy->unwatch_property( "scalar" ); - ok( exception { $objproxy->get_property( "no_such_property" ) }, + ok( exception { $objproxy->get_property( "no_such_property" )->get }, 'Getting no_such_property fails in proxy' ); } @@ -156,22 +158,22 @@ my $objproxy = $client->rootobj; ok( $f->is_ready, '$f is ready after MSG_WATCHING_ITER' ); - my ( $cursor, $first_idx, $last_idx ) = $f->get; + my ( $cursor, $first_idx, $last_idx ) = await $f; is( $first_idx, 0, '$first_idx after MSG_WATCHING_ITER' ); is( $last_idx, 2, '$last_idx after MSG_WATCHING_ITER' ); - my ( $idx, @more ) = $cursor->next_forward->get; + my ( $idx, @more ) = await $cursor->next_forward; is( $idx, 0, 'next_forward starts at element 0' ); is_deeply( \@more, [ 1 ], 'next_forward yielded 1 element' ); - ( $idx, @more ) = $cursor->next_forward( 5 )->get; + ( $idx, @more ) = await $cursor->next_forward( 5 ); is( $idx, 1, 'next_forward starts at element 1' ); is_deeply( \@more, [ 2, 3 ], 'next_forward yielded 2 elements' ); - ( $idx, @more ) = $cursor->next_backward->get; + ( $idx, @more ) = await $cursor->next_backward; is( $idx, 2, 'next_backward starts at element 2' ); is_deeply( \@more, [ 3 ], 'next_forward yielded 1 element' ); @@ -197,9 +199,9 @@ my $objproxy = $client->rootobj; # Test object destruction { my $proxy_destroyed = 0; - $objproxy->subscribe_event( "destroy", + await $objproxy->subscribe_event( "destroy", on_fire => sub { $proxy_destroyed = 1 }, - )->get; + ); my $obj_destroyed = 0; diff --git a/t/23close.t b/t/23close.t index 206f61b..06f0687 100644 --- a/t/23close.t +++ b/t/23close.t @@ -1,8 +1,10 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; +use Future::AsyncAwait 0.47; + use Test::More; use Tangence::Constants; @@ -32,13 +34,13 @@ my ( $conn1, $conn2 ) = map { objproxy => $objproxy, }; - $objproxy->watch_property( "scalar", + await $objproxy->watch_property( "scalar", on_set => sub { $conn->{scalar} = shift; }, - )->get; + ); - my ( $cursor ) = $objproxy->watch_property_with_cursor( "queue", "first", + my ( $cursor ) = await $objproxy->watch_property_with_cursor( "queue", "first", on_updated => sub {}, - )->get; + ); $conn } 1 .. 2; diff --git a/t/30props-cbs.t b/t/30props-cbs.t index b1263bd..d18a878 100644 --- a/t/30props-cbs.t +++ b/t/30props-cbs.t @@ -1,8 +1,10 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; +use Future::AsyncAwait 0.47; + use Test::More; use Test::Memory::Cycle; @@ -29,9 +31,9 @@ my $proxy = $client->rootobj; # SCALAR { my $scalar; - $proxy->watch_property_with_initial( "scalar", + await $proxy->watch_property_with_initial( "scalar", on_set => sub { $scalar = shift }, - )->get; + ); is( $scalar, "123", 'Initial value from watch_property "scalar"' ); @@ -41,9 +43,9 @@ my $proxy = $client->rootobj; is( $scalar, "1234", 'set scalar value' ); my $also_scalar; - $proxy->watch_property_with_initial( "scalar", + await $proxy->watch_property_with_initial( "scalar", on_updated => sub { $also_scalar = shift }, - )->get; + ); is( $also_scalar, "1234", 'Can watch_property a second time' ); } @@ -53,11 +55,11 @@ my $proxy = $client->rootobj; my $hash; my ( $a_key, $a_value ); my ( $d_key ); - $proxy->watch_property_with_initial( "hash", + await $proxy->watch_property_with_initial( "hash", on_set => sub { $hash = shift }, on_add => sub { ( $a_key, $a_value ) = @_ }, on_del => sub { ( $d_key ) = @_ }, - )->get; + ); is_deeply( $hash, { one => 1, two => 2, three => 3 }, @@ -79,11 +81,11 @@ my $proxy = $client->rootobj; my ( @p_values ); my ( $sh_count ); my ( $s_index, $s_count, @s_values ); - $proxy->watch_property_with_initial( "queue", + await $proxy->watch_property_with_initial( "queue", on_set => sub { $queue = shift }, on_push => sub { @p_values = @_ }, on_shift => sub { ( $sh_count ) = @_ }, - )->get; + ); $obj->push_prop_queue( 6 ); @@ -101,13 +103,13 @@ my $proxy = $client->rootobj; my ( $sh_count ); my ( $s_index, $s_count, @s_values ); my ( $m_index, $m_delta ); - $proxy->watch_property_with_initial( "array", + await $proxy->watch_property_with_initial( "array", on_set => sub { $array = shift }, on_push => sub { @p_values = @_ }, on_shift => sub { ( $sh_count ) = @_ }, on_splice => sub { ( $s_index, $s_count, @s_values ) = @_ }, on_move => sub { ( $m_index, $m_delta ) = @_ }, - )->get; + ); $obj->push_prop_array( 6 ); @@ -135,11 +137,11 @@ my $proxy = $client->rootobj; my $objset; my $added; my $deleted_id; - $proxy->watch_property_with_initial( "objset", + await $proxy->watch_property_with_initial( "objset", on_set => sub { $objset = shift }, on_add => sub { $added = shift }, on_del => sub { $deleted_id = shift }, - )->get; + ); # Shall have to construct some other TestObj objects to use here, as we can't # put regular ints in diff --git a/t/31props-cache.t b/t/31props-cache.t index e85f7fe..1319fa5 100644 --- a/t/31props-cache.t +++ b/t/31props-cache.t @@ -1,8 +1,10 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; +use Future::AsyncAwait 0.47; + use Test::More; use Test::Memory::Cycle; @@ -33,12 +35,12 @@ my $proxy = $client->rootobj; my $scalar; my $scalar_changed = 0; -$proxy->watch_property_with_initial( "scalar", +await $proxy->watch_property_with_initial( "scalar", on_set => sub { $scalar = shift; $scalar_changed = 1 }, -)->get; +); is( $scalar, "123", 'Initial value from watch_property' ); @@ -47,18 +49,18 @@ is( $proxy->prop( "scalar" ), "scalar property cache" ); my $hash_changed = 0; -$proxy->watch_property_with_initial( "hash", +await $proxy->watch_property_with_initial( "hash", on_updated => sub { $hash_changed = 1 }, -)->get; +); is_deeply( $proxy->prop( "hash" ), { one => 1, two => 2, three => 3 }, 'hash property cache' ); my $array_changed = 0; -$proxy->watch_property_with_initial( "array", +await $proxy->watch_property_with_initial( "array", on_updated => sub { $array_changed = 1 }, -)->get; +); is_deeply( $proxy->prop( "array" ), [ 1, 2, 3 ], diff --git a/t/32props-cursor.t b/t/32props-cursor.t index 19b03de..51ae3ea 100644 --- a/t/32props-cursor.t +++ b/t/32props-cursor.t @@ -1,8 +1,10 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; +use Future::AsyncAwait 0.47; + use Test::More; use Tangence::Registry; @@ -29,18 +31,18 @@ my $on_more = sub { # Fowards from first { - my ( $cursor, undef, $last_idx ) = $proxy->watch_property_with_cursor( + my ( $cursor, undef, $last_idx ) = await $proxy->watch_property_with_cursor( "queue", "first", on_set => sub { @value = @_ }, on_push => sub { push @value, @_ }, on_shift => sub { shift @value for 1 .. shift }, - )->get; + ); $#value = $last_idx; is_deeply( \@value, [ undef, undef, undef ], '@value initially' ); - $on_more->( $cursor->next_forward->get ); + $on_more->( await $cursor->next_forward ); is_deeply( \@value, [ 1, undef, undef ], '@value after first next_forward' ); @@ -48,7 +50,7 @@ my $on_more = sub { is_deeply( \@value, [ 1, undef, undef, 4, 5 ], '@value after push' ); - $on_more->( $cursor->next_forward->get ); + $on_more->( await $cursor->next_forward ); is_deeply( \@value, [ 1, 2, undef, 4, 5 ], '@value after second next_forward' ); @@ -56,7 +58,7 @@ my $on_more = sub { is_deeply( \@value, [ 2, undef, 4, 5 ], '@value after shift' ); - $on_more->( $cursor->next_forward->get ); + $on_more->( await $cursor->next_forward ); is_deeply( \@value, [ 2, 3, 4, 5 ], '@value after third next_forward' ); @@ -69,18 +71,18 @@ $obj->set_prop_queue( [ 1, 2, 3 ] ); # Backwards from last { - my ( $cursor, undef, $last_idx ) = $proxy->watch_property_with_cursor( + my ( $cursor, undef, $last_idx ) = await $proxy->watch_property_with_cursor( "queue", "last", on_set => sub { @value = @_ }, on_push => sub { push @value, @_ }, on_shift => sub { shift @value for 1 .. shift }, - )->get; + ); $#value = $last_idx; is_deeply( \@value, [ undef, undef, undef ], '@value initially' ); - $on_more->( $cursor->next_backward->get ); + $on_more->( await $cursor->next_backward ); is_deeply( \@value, [ undef, undef, 3 ], '@value after first next_backward' ); @@ -88,7 +90,7 @@ $obj->set_prop_queue( [ 1, 2, 3 ] ); is_deeply( \@value, [ undef, undef, 3, 4, 5 ], '@value after push' ); - $on_more->( $cursor->next_backward->get ); + $on_more->( await $cursor->next_backward ); is_deeply( \@value, [ undef, 2, 3, 4, 5 ], '@value after second next_backward' ); @@ -96,7 +98,7 @@ $obj->set_prop_queue( [ 1, 2, 3 ] ); is_deeply( \@value, [ 2, 3, 4, 5 ], '@value after shift' ); - $on_more->( $cursor->next_backward->get ); + $on_more->( await $cursor->next_backward ); is_deeply( \@value, [ 2, 3, 4, 5 ], '@value after third next_backward' ); diff --git a/t/33props-set.t b/t/33props-set.t index dd9f8ca..adc1214 100644 --- a/t/33props-set.t +++ b/t/33props-set.t @@ -1,8 +1,10 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; +use Future::AsyncAwait 0.47; + use Test::More; use Tangence::Registry; @@ -24,28 +26,28 @@ my $proxy = $client->rootobj; # scalar { - $proxy->set_property( "scalar", 456 )->get; + await $proxy->set_property( "scalar", 456 ); is( $obj->get_prop_scalar, 456, 'set_property on scalar' ); } # array { - $proxy->set_property( "array", [ 4, 5, 6 ] )->get; + await $proxy->set_property( "array", [ 4, 5, 6 ] ); is_deeply( $obj->get_prop_array, [ 4, 5, 6 ], 'set_property on array' ); } # queue { - $proxy->set_property( "queue", [ 4, 5, 6 ] )->get; + await $proxy->set_property( "queue", [ 4, 5, 6 ] ); is_deeply( $obj->get_prop_queue, [ 4, 5, 6 ], 'set_property on queue' ); } # hash { - $proxy->set_property( "hash", { four => 4, five => 5 } )->get; + await $proxy->set_property( "hash", { four => 4, five => 5 } ); is_deeply( $obj->get_prop_hash, { four => 4, five => 5 }, 'set_property on hash' ); } diff --git a/t/40server-security.t b/t/40server-security.t index ad318df..16df8c8 100644 --- a/t/40server-security.t +++ b/t/40server-security.t @@ -1,8 +1,10 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; +use Future::AsyncAwait 0.47; + use Test::More; use Tangence::Constants; @@ -28,10 +30,13 @@ my ( $server, $client ) = make_serverclient( $registry ); my $proxy = $client->rootobj; # gutwrench into the objectproxy to make a new one with a different ID -$proxy->{id} == $obj->id or die "ARGH failed to have correct object ID in proxy"; +$proxy->id == $obj->id or die "ARGH failed to have correct object ID in proxy"; -my $proxy2 = { %$proxy, id => $obj2->id }; -bless $proxy2, ref $proxy; +my $proxy2 = Tangence::ObjectProxy->new( + client => $proxy->client, + id => $obj2->id, + class => $obj->class, +); # $proxy2 should now not work for anything @@ -71,7 +76,7 @@ bless $proxy2, ref $proxy; # as argument to otherwise-allowed object { - $proxy->set_property( "objset", [ $proxy ] )->get; # is allowed + await $proxy->set_property( "objset", [ $proxy ] ); # is allowed my $f = $proxy->set_property( "objset", [ $proxy2 ] ); diff --git a/t/90close-leak.t b/t/90close-leak.t index 3395164..ca34c85 100644 --- a/t/90close-leak.t +++ b/t/90close-leak.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; use Test::More; @@ -1,6 +1,6 @@ #!/usr/bin/perl -use v5.14; +use v5.26; use warnings; use Test::More; @@ -1,16 +1,15 @@ package t::Ball; -use v5.14; +use v5.26; +use warnings; +use experimental 'signatures'; use base qw( Tangence::Object t::Colourable ); use Tangence::Constants; -sub new +sub new ( $class, %args ) { - my $class = shift; - my %args = @_; - my $self = $class->SUPER::new( %args ); $self->set_prop_colour( $args{colour} ) if defined $args{colour}; @@ -27,10 +26,8 @@ sub describe our $last_bounce_ctx; -sub method_bounce +sub method_bounce ( $self, $ctx, $howhigh ) { - my $self = shift; - my ( $ctx, $howhigh ) = @_; $last_bounce_ctx = $ctx; $self->fire_event( "bounced", $howhigh ); return "bouncing"; diff --git a/t/Colourable.pm b/t/Colourable.pm index 662e7b8..410fc6a 100644 --- a/t/Colourable.pm +++ b/t/Colourable.pm @@ -1,6 +1,6 @@ package t::Colourable; -use v5.14; +use v5.26; use Tangence::Constants; diff --git a/t/Conversation.pm b/t/Conversation.pm index 899a901..3adb662 100644 --- a/t/Conversation.pm +++ b/t/Conversation.pm @@ -1,6 +1,6 @@ package t::Conversation; -use v5.14; +use v5.26; use warnings; use Exporter 'import'; diff --git a/t/TestObj.pm b/t/TestObj.pm index 94a27b1..0c55aa3 100644 --- a/t/TestObj.pm +++ b/t/TestObj.pm @@ -1,15 +1,15 @@ package t::TestObj; -use v5.14; +use v5.26; +use warnings; +use experimental 'signatures'; use base qw( Tangence::Object ); use Tangence::Constants; -sub new +sub new ( $class, %args ) { - my $class = shift; - my %args = @_; my $self = $class->SUPER::new( %args ); for (qw( scalar array queue hash s_scalar )) { @@ -25,10 +25,8 @@ sub describe return (ref $self) . qq([scalar=) . $self->get_prop_scalar . q(]); } -sub method_method +sub method_method ( $self, $ctx, $i, $s ) { - my $self = shift; - my ( $ctx, $i, $s ) = @_; return "$i/$s"; } @@ -43,11 +41,8 @@ sub init_prop_hash { { one => 1, two => 2, three => 3 } } sub init_prop_queue { [ 1, 2, 3 ] } sub init_prop_array { [ 1, 2, 3 ] } -sub add_number +sub add_number ( $self, $name, $num ) { - my $self = shift; - my ( $name, $num ) = @_; - if( index( my $scalar = $self->get_prop_scalar, $num ) == -1 ) { $scalar .= $num; $self->set_prop_scalar( $scalar ); @@ -60,11 +55,8 @@ sub add_number } } -sub del_number +sub del_number ( $self, $num ) { - my $self = shift; - my ( $num ) = @_; - my $hash = $self->get_prop_hash; my $name; $hash->{$_} == $num and ( $name = $_, last ) for keys %$hash; diff --git a/t/TestServerClient.pm b/t/TestServerClient.pm index 8b637c1..3c6061e 100644 --- a/t/TestServerClient.pm +++ b/t/TestServerClient.pm @@ -1,17 +1,16 @@ package t::TestServerClient; -use v5.14; +use v5.26; use warnings; +use experimental 'signatures'; use Exporter 'import'; our @EXPORT = qw( make_serverclient ); use Scalar::Util qw( weaken ); -sub make_serverclient +sub make_serverclient ( $registry ) { - my ( $registry ) = @_; - my $server = TestServer->new(); my $client = TestClient->new(); @@ -33,10 +32,8 @@ sub new return bless {}, shift; } -sub tangence_write +sub tangence_write ( $self, $message ) { - my $self = shift; - my ( $message ) = @_; $self->{client}->tangence_readfrom( $message ); length($message) == 0 or die "Client failed to read all Server wrote"; } @@ -52,10 +49,8 @@ sub new return $self; } -sub tangence_write +sub tangence_write ( $self, $message ) { - my $self = shift; - my ( $message ) = @_; $self->{server}->tangence_readfrom( $message ); length($message) == 0 or die "Server failed to read all Client wrote"; } |