File Coverage

xsubs/tag.xs
Criterion Covered Total %
statement 31 32 96.8
branch 34 34 100.0
condition n/a
subroutine n/a
pod n/a
total 65 66 98.4


line stmt bran cond sub pod time code
1             ################################################################################
2             #
3             # Copyright (c) 2002-2020 Marcus Holland-Moritz. All rights reserved.
4             # This program is free software; you can redistribute it and/or modify
5             # it under the same terms as Perl itself.
6             #
7             ################################################################################
8              
9              
10             ################################################################################
11             #
12             # METHOD: tag / untag
13             #
14             # WRITTEN BY: Marcus Holland-Moritz ON: Dec 2004
15             # CHANGED BY: ON:
16             #
17             ################################################################################
18              
19             void
20             CBC::tag(type, ...)
21             const char *type
22              
23             ALIAS:
24             untag = 1
25              
26             PREINIT:
27 19656           CBC_METHOD_VAR;
28             TagTypeInfo tti;
29             CtTagList *taglist;
30              
31             CODE:
32 19656           switch (ix)
33             {
34             case 0:
35 19627           CBC_METHOD_SET("tag");
36 19627           break;
37              
38             case 1:
39 29           CBC_METHOD_SET("untag");
40 29           break;
41              
42             default:
43 0           fatal("Invalid alias (%d) for tag method", ix);
44             break;
45             }
46              
47             CT_DEBUG_METHOD1("'%s'", type);
48              
49 19656 100         if (ix == 0 && items <= 3 && GIMME_V == G_VOID)
    100          
    100          
    100          
50             {
51 24 100         WARN_VOID_CONTEXT;
52 24           XSRETURN_EMPTY;
53             }
54              
55 19632 100         NEED_PARSE_DATA;
    100          
56              
57 19632           tti.type = type;
58              
59 19632 100         if (!get_member_info(aTHX_ THIS, type, &tti.mi, 0))
60 12           Perl_croak(aTHX_ "Cannot find '%s'", type);
61              
62 19620 100         if (tti.mi.level != 0)
63 24           Perl_croak(aTHX_ "Cannot tag array members");
64              
65 58335           taglist = tti.mi.pDecl ? &tti.mi.pDecl->tags
66 19596 100         : find_taglist_ptr(tti.mi.type.ptr);
67              
68             assert(taglist != NULL);
69              
70 19596 100         if (ix == 0) /* tag */
71             {
72 19573 100         if (items == 2)
73 118           ST(0) = get_tags(aTHX_ &tti, *taglist);
74 19455 100         else if (items == 3)
75 236           handle_tag(aTHX_ &tti, taglist, ST(2), NULL, &ST(0));
76 19219 100         else if (items % 2 == 0)
77             {
78             int i;
79 38252 100         for (i = 2; i < items; i += 2)
80 19245           handle_tag(aTHX_ &tti, taglist, ST(i), ST(i+1), NULL);
81             }
82             else
83 6           Perl_croak(aTHX_ "Invalid number of arguments to %s", method);
84             }
85             else /* untag */
86             {
87 23 100         if (items == 2)
88 2           delete_all_tags(taglist);
89             else
90             {
91             int i;
92 36 100         for (i = 2; i < items; i++)
93 21           handle_tag(aTHX_ &tti, taglist, ST(i), &PL_sv_undef, NULL);
94             }
95             }
96              
97 19390           XSRETURN(1);
98